--- /dev/null
+AddCasts.cmi: C.cmi
+Bitfields.cmi: C.cmi
+Builtins.cmi: Env.cmi C.cmi
+Ceval.cmi: Env.cmi C.cmi
+Cleanup.cmi: C.cmi
+C.cmi:
+Cprint.cmi: C.cmi
+Cutil.cmi: Env.cmi C.cmi
+Elab.cmi: C.cmi
+Env.cmi: C.cmi
+Errors.cmi:
+GCC.cmi: Builtins.cmi
+Lexer.cmi: Parser.cmi
+Machine.cmi:
+Parse_aux.cmi:
+Parse.cmi: C.cmi
+Parser.cmi: Cabs.cmo
+Rename.cmi: C.cmi
+SimplExpr.cmi: C.cmi
+StructAssign.cmi: C.cmi
+StructByValue.cmi: C.cmi
+Transform.cmi: Env.cmi C.cmi
+Unblock.cmi: C.cmi
+AddCasts.cmo: Transform.cmi Cutil.cmi C.cmi AddCasts.cmi
+AddCasts.cmx: Transform.cmx Cutil.cmx C.cmi AddCasts.cmi
+Bitfields.cmo: Transform.cmi Machine.cmi Cutil.cmi C.cmi Bitfields.cmi
+Bitfields.cmx: Transform.cmx Machine.cmx Cutil.cmx C.cmi Bitfields.cmi
+Builtins.cmo: Env.cmi Cutil.cmi C.cmi Builtins.cmi
+Builtins.cmx: Env.cmx Cutil.cmx C.cmi Builtins.cmi
+Cabshelper.cmo: Cabs.cmo
+Cabshelper.cmx: Cabs.cmx
+Cabs.cmo:
+Cabs.cmx:
+Ceval.cmo: Machine.cmi Cutil.cmi C.cmi Ceval.cmi
+Ceval.cmx: Machine.cmx Cutil.cmx C.cmi Ceval.cmi
+Cleanup.cmo: Cutil.cmi C.cmi Cleanup.cmi
+Cleanup.cmx: Cutil.cmx C.cmi Cleanup.cmi
+Cprint.cmo: C.cmi Cprint.cmi
+Cprint.cmx: C.cmi Cprint.cmi
+Cutil.cmo: Machine.cmi Errors.cmi Env.cmi Cprint.cmi C.cmi Cutil.cmi
+Cutil.cmx: Machine.cmx Errors.cmx Env.cmx Cprint.cmx C.cmi Cutil.cmi
+Elab.cmo: Parser.cmi Machine.cmi Lexer.cmi Errors.cmi Env.cmi Cutil.cmi \
+ Cprint.cmi Cleanup.cmi Ceval.cmi Cabshelper.cmo Cabs.cmo C.cmi \
+ Builtins.cmi Elab.cmi
+Elab.cmx: Parser.cmx Machine.cmx Lexer.cmx Errors.cmx Env.cmx Cutil.cmx \
+ Cprint.cmx Cleanup.cmx Ceval.cmx Cabshelper.cmx Cabs.cmx C.cmi \
+ Builtins.cmx Elab.cmi
+Env.cmo: C.cmi Env.cmi
+Env.cmx: C.cmi Env.cmi
+Errors.cmo: Errors.cmi
+Errors.cmx: Errors.cmi
+GCC.cmo: Cutil.cmi C.cmi Builtins.cmi GCC.cmi
+GCC.cmx: Cutil.cmx C.cmi Builtins.cmx GCC.cmi
+Lexer.cmo: Parser.cmi Parse_aux.cmi Cabshelper.cmo Lexer.cmi
+Lexer.cmx: Parser.cmx Parse_aux.cmx Cabshelper.cmx Lexer.cmi
+Machine.cmo: Machine.cmi
+Machine.cmx: Machine.cmi
+Main.cmo: Parse.cmi GCC.cmi Cprint.cmi Builtins.cmi
+Main.cmx: Parse.cmx GCC.cmx Cprint.cmx Builtins.cmx
+Parse_aux.cmo: Errors.cmi Cabshelper.cmo Parse_aux.cmi
+Parse_aux.cmx: Errors.cmx Cabshelper.cmx Parse_aux.cmi
+Parse.cmo: Unblock.cmi StructByValue.cmi StructAssign.cmi SimplExpr.cmi \
+ Rename.cmi Errors.cmi Elab.cmi Bitfields.cmi AddCasts.cmi Parse.cmi
+Parse.cmx: Unblock.cmx StructByValue.cmx StructAssign.cmx SimplExpr.cmx \
+ Rename.cmx Errors.cmx Elab.cmx Bitfields.cmx AddCasts.cmx Parse.cmi
+Parser.cmo: Parse_aux.cmi Cabshelper.cmo Cabs.cmo Parser.cmi
+Parser.cmx: Parse_aux.cmx Cabshelper.cmx Cabs.cmx Parser.cmi
+Rename.cmo: Errors.cmi Cutil.cmi C.cmi Builtins.cmi Rename.cmi
+Rename.cmx: Errors.cmx Cutil.cmx C.cmi Builtins.cmx Rename.cmi
+SimplExpr.cmo: Transform.cmi Errors.cmi Cutil.cmi C.cmi SimplExpr.cmi
+SimplExpr.cmx: Transform.cmx Errors.cmx Cutil.cmx C.cmi SimplExpr.cmi
+StructAssign.cmo: Transform.cmi Errors.cmi Env.cmi Cutil.cmi C.cmi \
+ StructAssign.cmi
+StructAssign.cmx: Transform.cmx Errors.cmx Env.cmx Cutil.cmx C.cmi \
+ StructAssign.cmi
+StructByValue.cmo: Transform.cmi Env.cmi Cutil.cmi C.cmi StructByValue.cmi
+StructByValue.cmx: Transform.cmx Env.cmx Cutil.cmx C.cmi StructByValue.cmi
+Transform.cmo: Env.cmi Cutil.cmi C.cmi Builtins.cmi Transform.cmi
+Transform.cmx: Env.cmx Cutil.cmx C.cmi Builtins.cmx Transform.cmi
+Unblock.cmo: Transform.cmi Errors.cmi Cutil.cmi C.cmi Unblock.cmi
+Unblock.cmx: Transform.cmx Errors.cmx Cutil.cmx C.cmi Unblock.cmi
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Materialize implicit casts *)
+
+(* Assumes: simplified code
+ Produces: simplified code
+ Preserves: unblocked code *)
+
+open C
+open Cutil
+open Transform
+
+(* We have the option of materializing all casts or leave "widening"
+ casts implicit. Widening casts are:
+- from a small integer type to a larger integer type,
+- from a small float type to a larger float type,
+- from a pointer type to void *.
+*)
+
+let omit_widening_casts = ref false
+
+let widening_cast env tfrom tto =
+ begin match unroll env tfrom, unroll env tto with
+ | TInt(k1, _), TInt(k2, _) ->
+ let r1 = integer_rank k1 and r2 = integer_rank k2 in
+ r1 < r2 || (r1 = r2 && is_signed_ikind k1 = is_signed_ikind k2)
+ | TFloat(k1, _), TFloat(k2, _) ->
+ float_rank k1 <= float_rank k2
+ | TPtr(ty1, _), TPtr(ty2, _) -> is_void_type env ty2
+ | _, _ -> false
+ end
+
+let cast_not_needed env tfrom tto =
+ let tfrom = pointer_decay env tfrom
+ and tto = pointer_decay env tto in
+ compatible_types env tfrom tto
+ || (!omit_widening_casts && widening_cast env tfrom tto)
+
+let cast env e tto =
+ if cast_not_needed env e.etyp tto
+ then e
+ else {edesc = ECast(tto, e); etyp = tto}
+
+(* Note: this pass applies only to simplified expressions
+ because casts cannot be materialized in op= expressions... *)
+
+let rec add_expr env e =
+ match e.edesc with
+ | EConst _ -> e
+ | EVar _ -> e
+ | ESizeof _ -> e
+ | EUnop(op, e1) ->
+ let e1' = add_expr env e1 in
+ let desc =
+ match op with
+ | Ominus | Oplus | Onot ->
+ EUnop(op, cast env e1' e.etyp)
+ | Olognot | Oderef | Oaddrof
+ | Odot _ | Oarrow _ ->
+ EUnop(op, e1')
+ | Opreincr | Opredecr | Opostincr | Opostdecr ->
+ assert false (* not simplified *)
+ in { edesc = desc; etyp = e.etyp }
+ | EBinop(op, e1, e2, ty) ->
+ let e1' = add_expr env e1 in
+ let e2' = add_expr env e2 in
+ let desc =
+ match op with
+ | Oadd ->
+ if is_pointer_type env ty
+ then EBinop(Oadd, e1', e2', ty)
+ else EBinop(Oadd, cast env e1' ty, cast env e2' ty, ty)
+ | Osub ->
+ if is_pointer_type env ty
+ then EBinop(Osub, e1', e2', ty)
+ else EBinop(Osub, cast env e1' ty, cast env e2' ty, ty)
+ | Omul|Odiv|Omod|Oand|Oor|Oxor|Oeq|One|Olt|Ogt|Ole|Oge ->
+ EBinop(op, cast env e1' ty, cast env e2' ty, ty)
+ | Oshl|Oshr ->
+ EBinop(op, cast env e1' ty, e2', ty)
+ | Oindex | Ologand | Ologor | Ocomma ->
+ EBinop(op, e1', e2', ty)
+ | Oassign
+ | Oadd_assign|Osub_assign|Omul_assign|Odiv_assign|Omod_assign
+ | Oand_assign|Oor_assign|Oxor_assign|Oshl_assign|Oshr_assign ->
+ assert false (* not simplified *)
+ in { edesc = desc; etyp = e.etyp }
+ | EConditional(e1, e2, e3) ->
+ let e2' = add_expr env e2 in
+ let e3' = add_expr env e3 in
+ { edesc =
+ EConditional(add_expr env e1, cast env e2' e.etyp, cast env e3' e.etyp);
+ etyp = e.etyp }
+ | ECast(ty, e1) ->
+ { edesc = ECast(ty, add_expr env e1); etyp = e.etyp }
+ | ECall(e1, el) ->
+ assert false (* not simplified *)
+
+(* Arguments to a prototyped function *)
+
+let rec add_proto env args params =
+ match args, params with
+ | [], _ -> []
+ | _::_, [] -> add_noproto env args
+ | arg1 :: argl, (_, ty_p) :: paraml ->
+ cast env (add_expr env arg1) ty_p ::
+ add_proto env argl paraml
+
+(* Arguments to a non-prototyped function *)
+
+and add_noproto env args =
+ match args with
+ | [] -> []
+ | arg1 :: argl ->
+ cast env (add_expr env arg1) (default_argument_conversion env arg1.etyp) ::
+ add_noproto env argl
+
+(* Arguments to function calls in general *)
+
+let add_arguments env ty_fun args =
+ let ty_args =
+ match unroll env ty_fun with
+ | TFun(res, args, vararg, a) -> args
+ | TPtr(ty, a) ->
+ begin match unroll env ty with
+ | TFun(res, args, vararg, a) -> args
+ | _ -> assert false
+ end
+ | _ -> assert false in
+ match ty_args with
+ | None -> add_noproto env args
+ | Some targs -> add_proto env args targs
+
+(* Toplevel expressions (appearing in Sdo statements) *)
+
+let add_topexpr env loc e =
+ match e.edesc with
+ | EBinop(Oassign, lhs, {edesc = ECall(e1, el); etyp = ty}, _) ->
+ let ecall =
+ {edesc = ECall(add_expr env e1, add_arguments env e1.etyp el);
+ etyp = ty} in
+ if cast_not_needed env ty lhs.etyp then
+ sassign loc (add_expr env lhs) ecall
+ else begin
+ let tmp = new_temp (erase_attributes_type env ty) in
+ sseq loc (sassign loc tmp ecall)
+ (sassign loc (add_expr env lhs) (cast env tmp lhs.etyp))
+ end
+ | EBinop(Oassign, lhs, rhs, _) ->
+ sassign loc (add_expr env lhs) (cast env (add_expr env rhs) lhs.etyp)
+ | ECall(e1, el) ->
+ let ecall =
+ {edesc = ECall(add_expr env e1, add_arguments env e1.etyp el);
+ etyp = e.etyp} in
+ {sdesc = Sdo ecall; sloc = loc}
+ | _ ->
+ assert false
+
+(* Initializers *)
+
+let rec add_init env tto = function
+ | Init_single e ->
+ Init_single (cast env (add_expr env e) tto)
+ | Init_array il ->
+ let ty_elt =
+ match unroll env tto with
+ | TArray(ty, _, _) -> ty | _ -> assert false in
+ Init_array (List.map (add_init env ty_elt) il)
+ | Init_struct(id, fil) ->
+ Init_struct (id, List.map
+ (fun (fld, i) -> (fld, add_init env fld.fld_typ i))
+ fil)
+ | Init_union(id, fld, i) ->
+ Init_union(id, fld, add_init env fld.fld_typ i)
+
+(* Declarations *)
+
+let add_decl env (sto, id, ty, optinit) =
+ (sto, id, ty,
+ begin match optinit with
+ | None -> None
+ | Some init -> Some(add_init env ty init)
+ end)
+
+(* Statements *)
+
+let rec add_stmt env f s =
+ match s.sdesc with
+ | Sskip -> s
+ | Sdo e -> add_topexpr env s.sloc e
+ | Sseq(s1, s2) ->
+ {sdesc = Sseq(add_stmt env f s1, add_stmt env f s2); sloc = s.sloc }
+ | Sif(e, s1, s2) ->
+ {sdesc = Sif(add_expr env e, add_stmt env f s1, add_stmt env f s2);
+ sloc = s.sloc}
+ | Swhile(e, s1) ->
+ {sdesc = Swhile(add_expr env e, add_stmt env f s1);
+ sloc = s.sloc}
+ | Sdowhile(s1, e) ->
+ {sdesc = Sdowhile(add_stmt env f s1, add_expr env e);
+ sloc = s.sloc}
+ | Sfor(s1, e, s2, s3) ->
+ {sdesc = Sfor(add_stmt env f s1, add_expr env e, add_stmt env f s2,
+ add_stmt env f s3);
+ sloc = s.sloc}
+ | Sbreak -> s
+ | Scontinue -> s
+ | Sswitch(e, s1) ->
+ {sdesc = Sswitch(add_expr env e, add_stmt env f s1); sloc = s.sloc}
+ | Slabeled(lbl, s) ->
+ {sdesc = Slabeled(lbl, add_stmt env f s); sloc = s.sloc}
+ | Sgoto lbl -> s
+ | Sreturn None -> s
+ | Sreturn (Some e) ->
+ {sdesc = Sreturn(Some(cast env (add_expr env e) f.fd_ret)); sloc = s.sloc}
+ | Sblock sl ->
+ {sdesc = Sblock(List.map (add_stmt env f) sl); sloc = s.sloc}
+ | Sdecl d ->
+ {sdesc = Sdecl(add_decl env d); sloc = s.sloc}
+
+let add_fundef env f =
+ reset_temps();
+ let body' = add_stmt env f f.fd_body in
+ let temps = get_temps () in
+ (* fd_locals have no initializers, so no need to transform them *)
+ { f with fd_locals = f.fd_locals @ temps; fd_body = body' }
+
+
+let program ?(all = false) p =
+ omit_widening_casts := not all;
+ Transform.program ~decl:add_decl ~fundef:add_fundef p
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val program: ?all: bool -> C.program -> C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Elimination of bit fields in structs *)
+
+(* Assumes: unblocked, simplified code.
+ Preserves: unblocked, simplified code. *)
+
+open Printf
+open Machine
+open C
+open Cutil
+open Transform
+
+(* Info associated to each bitfield *)
+
+type bitfield_info =
+ { bf_carrier: string; (* name of underlying regular field *)
+ bf_carrier_typ: typ; (* type of underlying regular field *)
+ bf_pos: int; (* start bit *)
+ bf_size: int; (* size in bit *)
+ bf_signed: bool } (* signed or unsigned *)
+
+(* invariants:
+ 0 <= pos < bitsizeof(int)
+ 0 < sz <= bitsizeof(int)
+ 0 < pos + sz <= bitsizeof(int)
+*)
+
+(* Mapping (struct identifier, bitfield name) -> bitfield info *)
+
+let bitfield_table =
+ (Hashtbl.create 57: (ident * string, bitfield_info) Hashtbl.t)
+
+(* Packing algorithm -- keep consistent with [Cutil.pack_bitfield]! *)
+
+let unsigned_ikind_for_carrier nbits =
+ if nbits <= 8 then IUChar else
+ if nbits <= 8 * !config.sizeof_short then IUShort else
+ if nbits <= 8 * !config.sizeof_int then IUInt else
+ if nbits <= 8 * !config.sizeof_long then IULong else
+ if nbits <= 8 * !config.sizeof_longlong then IULongLong else
+ assert false
+
+let pack_bitfields env id ml =
+ let rec pack accu pos = function
+ | [] ->
+ (pos, accu, [])
+ | m :: ms as ml ->
+ match m.fld_bitfield with
+ | None -> (pos, accu, ml)
+ | Some n ->
+ if n = 0 then
+ (pos, accu, ms) (* bit width 0 means end of pack *)
+ else if pos + n > 8 * !config.sizeof_int then
+ (pos, accu, ml) (* doesn't fit in current word *)
+ else begin
+ let signed =
+ match unroll env m.fld_typ with
+ | TInt(ik, _) -> is_signed_ikind ik
+ | _ -> assert false (* should never happen, checked in Elab *) in
+ pack ((m.fld_name, pos, n, signed) :: accu) (pos + n) ms
+ end
+ in pack [] 0 ml
+
+let rec transf_members env id count = function
+ | [] -> []
+ | m :: ms as ml ->
+ if m.fld_bitfield = None then
+ m :: transf_members env id count ms
+ else begin
+ let (nbits, bitfields, ml') = pack_bitfields env id ml in
+ let carrier = sprintf "__bf%d" count in
+ let carrier_typ = TInt(unsigned_ikind_for_carrier nbits, []) in
+ List.iter
+ (fun (name, pos, sz, signed) ->
+ Hashtbl.add bitfield_table
+ (id, name)
+ {bf_carrier = carrier; bf_carrier_typ = carrier_typ;
+ bf_pos = pos; bf_size = sz; bf_signed = signed})
+ bitfields;
+ { fld_name = carrier; fld_typ = carrier_typ; fld_bitfield = None}
+ :: transf_members env id (count + 1) ml'
+ end
+
+let transf_composite env su id ml =
+ match su with
+ | Struct -> transf_members env id 1 ml
+ | Union -> ml
+
+(* Bitfield manipulation expressions *)
+
+let left_shift_count bf =
+ intconst
+ (Int64.of_int (8 * !config.sizeof_int - (bf.bf_pos + bf.bf_size)))
+ IInt
+
+let right_shift_count bf =
+ intconst
+ (Int64.of_int (8 * !config.sizeof_int - bf.bf_size))
+ IInt
+
+let insertion_mask bf =
+ let m =
+ Int64.shift_left
+ (Int64.pred (Int64.shift_left 1L bf.bf_size))
+ bf.bf_pos in
+ (* Give the mask an hexadecimal string representation, nicer to read *)
+ {edesc = EConst(CInt(m, IUInt, sprintf "0x%LXU" m)); etyp = TInt(IUInt, [])}
+
+(* Extract the value of a bitfield *)
+
+(* Reference C code:
+
+unsigned int bitfield_unsigned_extract(unsigned int x, int ofs, int sz)
+{
+ return (x << (BITSIZE_UINT - (ofs + sz))) >> (BITSIZE_UINT - sz);
+}
+
+signed int bitfield_signed_extract(unsigned int x, int ofs, int sz)
+{
+ return ((signed int) (x << (BITSIZE_UINT - (ofs + sz))))
+ >> (BITSIZE_UINT - sz);
+}
+
+*)
+
+let bitfield_extract bf carrier =
+ let e1 =
+ {edesc = EBinop(Oshl, carrier, left_shift_count bf, TInt(IUInt, []));
+ etyp = carrier.etyp} in
+ let ty = TInt((if bf.bf_signed then IInt else IUInt), []) in
+ let e2 =
+ {edesc = ECast(ty, e1); etyp = ty} in
+ {edesc = EBinop(Oshr, e2, right_shift_count bf, e2.etyp);
+ etyp = e2.etyp}
+
+(* Assign a bitfield within a carrier *)
+
+(* Reference C code:
+
+unsigned int bitfield_insert(unsigned int x, int ofs, int sz, unsigned int y)
+{
+ unsigned int mask = ((1U << sz) - 1) << ofs;
+ return (x & ~mask) | ((y << ofs) & mask);
+}
+
+*)
+
+let bitfield_assign bf carrier newval =
+ let msk = insertion_mask bf in
+ let notmsk = {edesc = EUnop(Onot, msk); etyp = msk.etyp} in
+ let newval_shifted =
+ {edesc = EBinop(Oshl, newval, intconst (Int64.of_int bf.bf_pos) IUInt,
+ TInt(IUInt,[]));
+ etyp = TInt(IUInt,[])} in
+ let newval_masked =
+ {edesc = EBinop(Oand, newval_shifted, msk, TInt(IUInt,[]));
+ etyp = TInt(IUInt,[])}
+ and oldval_masked =
+ {edesc = EBinop(Oand, carrier, notmsk, TInt(IUInt,[]));
+ etyp = TInt(IUInt,[])} in
+ {edesc = EBinop(Oor, oldval_masked, newval_masked, TInt(IUInt,[]));
+ etyp = TInt(IUInt,[])}
+
+(* Expressions *)
+
+let transf_expr env e =
+
+ let is_bitfield_access ty fieldname =
+ match unroll env ty with
+ | TStruct(id, _) ->
+ (try Some(Hashtbl.find bitfield_table (id, fieldname))
+ with Not_found -> None)
+ | _ -> None in
+
+ let is_bitfield_access_ptr ty fieldname =
+ match unroll env ty with
+ | TPtr(ty', _) -> is_bitfield_access ty' fieldname
+ | _ -> None in
+
+ let rec texp e =
+ match e.edesc with
+ | EConst _ -> e
+ | ESizeof _ -> e
+ | EVar _ -> e
+
+ | EUnop(Odot fieldname, e1) ->
+ let e1' = texp e1 in
+ begin match is_bitfield_access e1.etyp fieldname with
+ | None ->
+ {edesc = EUnop(Odot fieldname, e1'); etyp = e.etyp}
+ | Some bf ->
+ bitfield_extract bf
+ {edesc = EUnop(Odot bf.bf_carrier, e1');
+ etyp = bf.bf_carrier_typ}
+ end
+
+ | EUnop(Oarrow fieldname, e1) ->
+ let e1' = texp e1 in
+ begin match is_bitfield_access_ptr e1.etyp fieldname with
+ | None ->
+ {edesc = EUnop(Oarrow fieldname, e1'); etyp = e.etyp}
+ | Some bf ->
+ bitfield_extract bf
+ {edesc = EUnop(Oarrow bf.bf_carrier, e1');
+ etyp = bf.bf_carrier_typ}
+ end
+
+ | EUnop(op, e1) ->
+ (* Note: simplified expr, so no ++/-- *)
+ {edesc = EUnop(op, texp e1); etyp = e.etyp}
+
+ | EBinop(Oassign, e1, e2, ty) ->
+ begin match e1.edesc with
+ | EUnop(Odot fieldname, e11) ->
+ let lhs = texp e11 in let rhs = texp e2 in
+ begin match is_bitfield_access e11.etyp fieldname with
+ | None ->
+ {edesc = EBinop(Oassign,
+ {edesc = EUnop(Odot fieldname, lhs);
+ etyp = e1.etyp},
+ rhs, ty);
+ etyp = e.etyp}
+ | Some bf ->
+ let carrier =
+ {edesc = EUnop(Odot bf.bf_carrier, lhs);
+ etyp = bf.bf_carrier_typ} in
+ {edesc = EBinop(Oassign, carrier,
+ bitfield_assign bf carrier rhs,
+ carrier.etyp);
+ etyp = carrier.etyp}
+ end
+ | EUnop(Oarrow fieldname, e11) ->
+ let lhs = texp e11 in let rhs = texp e2 in
+ begin match is_bitfield_access_ptr e11.etyp fieldname with
+ | None ->
+ {edesc = EBinop(Oassign,
+ {edesc = EUnop(Oarrow fieldname, lhs);
+ etyp = e1.etyp},
+ rhs, ty);
+ etyp = e.etyp}
+ | Some bf ->
+ let carrier =
+ {edesc = EUnop(Oarrow bf.bf_carrier, lhs);
+ etyp = bf.bf_carrier_typ} in
+ {edesc = EBinop(Oassign, carrier,
+ bitfield_assign bf carrier rhs,
+ carrier.etyp);
+ etyp = carrier.etyp}
+ end
+ | _ ->
+ {edesc = EBinop(Oassign, texp e1, texp e2, e1.etyp); etyp = e1.etyp}
+ end
+
+ | EBinop(op, e1, e2, ty) ->
+ (* Note: simplified expr assumed, so no assign-op *)
+ {edesc = EBinop(op, texp e1, texp e2, ty); etyp = e.etyp}
+ | EConditional(e1, e2, e3) ->
+ {edesc = EConditional(texp e1, texp e2, texp e3); etyp = e.etyp}
+ | ECast(ty, e1) ->
+ {edesc = ECast(ty, texp e1); etyp = e.etyp}
+ | ECall(e1, el) ->
+ {edesc = ECall(texp e1, List.map texp el); etyp = e.etyp}
+
+ in texp e
+
+(* Statements *)
+
+let rec transf_stmt env s =
+ match s.sdesc with
+ | Sskip -> s
+ | Sdo e ->
+ {sdesc = Sdo(transf_expr env e); sloc = s.sloc}
+ | Sseq(s1, s2) ->
+ {sdesc = Sseq(transf_stmt env s1, transf_stmt env s2); sloc = s.sloc }
+ | Sif(e, s1, s2) ->
+ {sdesc = Sif(transf_expr env e, transf_stmt env s1, transf_stmt env s2);
+ sloc = s.sloc}
+ | Swhile(e, s1) ->
+ {sdesc = Swhile(transf_expr env e, transf_stmt env s1);
+ sloc = s.sloc}
+ | Sdowhile(s1, e) ->
+ {sdesc = Sdowhile(transf_stmt env s1, transf_expr env e);
+ sloc = s.sloc}
+ | Sfor(s1, e, s2, s3) ->
+ {sdesc = Sfor(transf_stmt env s1, transf_expr env e, transf_stmt env s2,
+ transf_stmt env s3);
+ sloc = s.sloc}
+ | Sbreak -> s
+ | Scontinue -> s
+ | Sswitch(e, s1) ->
+ {sdesc = Sswitch(transf_expr env e, transf_stmt env s1); sloc = s.sloc}
+ | Slabeled(lbl, s) ->
+ {sdesc = Slabeled(lbl, transf_stmt env s); sloc = s.sloc}
+ | Sgoto lbl -> s
+ | Sreturn None -> s
+ | Sreturn (Some e) ->
+ {sdesc = Sreturn(Some(transf_expr env e)); sloc = s.sloc}
+ | Sblock _ | Sdecl _ ->
+ assert false (* should not occur in unblocked code *)
+
+(* Functions *)
+
+let transf_fundef env f =
+ { f with fd_body = transf_stmt env f.fd_body }
+
+(* Initializers *)
+
+let bitfield_initializer bf i =
+ match i with
+ | Init_single e ->
+ let m = Int64.pred (Int64.shift_left 1L bf.bf_size) in
+ let e_mask =
+ {edesc = EConst(CInt(m, IUInt, sprintf "0x%LXU" m));
+ etyp = TInt(IUInt, [])} in
+ let e_and =
+ {edesc = EBinop(Oand, e, e_mask, TInt(IUInt,[]));
+ etyp = TInt(IUInt,[])} in
+ {edesc = EBinop(Oshl, e_and, intconst (Int64.of_int bf.bf_pos) IInt,
+ TInt(IUInt, []));
+ etyp = TInt(IUInt, [])}
+ | _ -> assert false
+
+let rec pack_bitfield_init id carrier fld_init_list =
+ match fld_init_list with
+ | [] -> ([], [])
+ | (fld, i) :: rem ->
+ try
+ let bf = Hashtbl.find bitfield_table (id, fld.fld_name) in
+ if bf.bf_carrier <> carrier then
+ ([], fld_init_list)
+ else begin
+ let (el, rem') = pack_bitfield_init id carrier rem in
+ (bitfield_initializer bf i :: el, rem')
+ end
+ with Not_found ->
+ ([], fld_init_list)
+
+let rec or_expr_list = function
+ | [] -> assert false
+ | [e] -> e
+ | e1 :: el ->
+ {edesc = EBinop(Oor, e1, or_expr_list el, TInt(IUInt,[]));
+ etyp = TInt(IUInt,[])}
+
+let rec transf_struct_init id fld_init_list =
+ match fld_init_list with
+ | [] -> []
+ | (fld, i) :: rem ->
+ try
+ let bf = Hashtbl.find bitfield_table (id, fld.fld_name) in
+ let (el, rem') =
+ pack_bitfield_init id bf.bf_carrier fld_init_list in
+ ({fld_name = bf.bf_carrier; fld_typ = bf.bf_carrier_typ;
+ fld_bitfield = None},
+ Init_single {edesc = ECast(bf.bf_carrier_typ, or_expr_list el);
+ etyp = bf.bf_carrier_typ})
+ :: transf_struct_init id rem'
+ with Not_found ->
+ (fld, i) :: transf_struct_init id rem
+
+let rec transf_init env i =
+ match i with
+ | Init_single e -> Init_single (transf_expr env e)
+ | Init_array il -> Init_array (List.map (transf_init env) il)
+ | Init_struct(id, fld_init_list) ->
+ let fld_init_list' =
+ List.map (fun (f, i) -> (f, transf_init env i)) fld_init_list in
+ Init_struct(id, transf_struct_init id fld_init_list')
+ | Init_union(id, fld, i) -> Init_union(id, fld, transf_init env i)
+
+let transf_decl env (sto, id, ty, init_opt) =
+ (sto, id, ty,
+ match init_opt with None -> None | Some i -> Some(transf_init env i))
+
+(* Programs *)
+
+let program p =
+ Transform.program
+ ~composite:transf_composite
+ ~decl: transf_decl
+ ~fundef:transf_fundef
+ p
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val program: C.program -> C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Compiler built-ins *)
+
+open C
+open Cutil
+
+let env = ref Env.empty
+let idents = ref []
+let decls = ref []
+
+let environment () = !env
+let identifiers () = !idents
+let declarations () = List.rev !decls
+
+let add_typedef (s, ty) =
+ let (id, env') = Env.enter_typedef !env s ty in
+ env := env';
+ idents := id :: !idents;
+ decls := {gdesc = Gtypedef(id, ty); gloc = no_loc} :: !decls
+
+let add_function (s, (res, args, va)) =
+ let ty =
+ TFun(res,
+ Some (List.map (fun ty -> (Env.fresh_ident "", ty)) args),
+ va, []) in
+ let (id, env') = Env.enter_ident !env s Storage_extern ty in
+ env := env';
+ idents := id :: !idents;
+ decls := {gdesc = Gdecl(Storage_extern, id, ty, None); gloc = no_loc} :: !decls
+
+type t = {
+ typedefs: (string * C.typ) list;
+ functions: (string * (C.typ * C.typ list * bool)) list
+}
+
+let set blt =
+ env := Env.empty;
+ idents := [];
+ List.iter add_typedef blt.typedefs;
+ List.iter add_function blt.functions
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val environment: unit -> Env.t
+val identifiers: unit -> C.ident list
+val declarations: unit -> C.globdecl list
+
+type t = {
+ typedefs: (string * C.typ) list;
+ functions: (string * (C.typ * C.typ list * bool)) list
+}
+
+val set: t -> unit
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* C abstract syntax after elaboration *)
+
+(* Locations *)
+
+type location = string * int (* filename, line number *)
+
+(* Identifiers *)
+
+type ident =
+ { name: string; (* name as in the source *)
+ stamp: int } (* unique ID *)
+
+(* kinds of integers *)
+
+type ikind =
+ | IBool (** [_Bool] *)
+ | IChar (** [char] *)
+ | ISChar (** [signed char] *)
+ | IUChar (** [unsigned char] *)
+ | IInt (** [int] *)
+ | IUInt (** [unsigned int] *)
+ | IShort (** [short] *)
+ | IUShort (** [unsigned short] *)
+ | ILong (** [long] *)
+ | IULong (** [unsigned long] *)
+ | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *)
+ | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft
+ Visual C) *)
+
+(** Kinds of floating-point numbers*)
+
+type fkind =
+ FFloat (** [float] *)
+ | FDouble (** [double] *)
+ | FLongDouble (** [long double] *)
+
+
+(** Constants *)
+
+type constant =
+ | CInt of int64 * ikind * string (* as it appeared in the source *)
+ | CFloat of float * fkind * string (* as it appeared in the source *)
+ | CStr of string
+ | CWStr of int64 list
+ | CEnum of ident * int64 (* enum tag, integer value *)
+
+(** Attributes *)
+
+type attribute = AConst | AVolatile | ARestrict
+
+type attributes = attribute list
+
+(** Storage classes *)
+
+type storage =
+ | Storage_default
+ | Storage_extern
+ | Storage_static
+ | Storage_register
+
+(** Unary operators *)
+
+type unary_operator =
+ | Ominus (* unary "-" *)
+ | Oplus (* unary "+" *)
+ | Olognot (* "!" *)
+ | Onot (* "~" *)
+ | Oderef (* unary "*" *)
+ | Oaddrof (* "&" *)
+ | Opreincr (* "++" prefix *)
+ | Opredecr (* "--" prefix *)
+ | Opostincr (* "++" postfix *)
+ | Opostdecr (* "--" postfix *)
+ | Odot of string (* ".field" *)
+ | Oarrow of string (* "->field" *)
+
+type binary_operator =
+ | Oadd (* binary "+" *)
+ | Osub (* binary "-" *)
+ | Omul (* binary "*" *)
+ | Odiv (* "/" *)
+ | Omod (* "%" *)
+ | Oand (* "&" *)
+ | Oor (* "|" *)
+ | Oxor (* "^" *)
+ | Oshl (* "<<" *)
+ | Oshr (* ">>" *)
+ | Oeq (* "==" *)
+ | One (* "!=" *)
+ | Olt (* "<" *)
+ | Ogt (* ">" *)
+ | Ole (* "<=" *)
+ | Oge (* ">=" *)
+ | Oindex (* "a[i]" *)
+ | Oassign (* "=" *)
+ | Oadd_assign (* "+=" *)
+ | Osub_assign (* "-=" *)
+ | Omul_assign (* "*=" *)
+ | Odiv_assign (* "/=" *)
+ | Omod_assign (* "%=" *)
+ | Oand_assign (* "&=" *)
+ | Oor_assign (* "|=" *)
+ | Oxor_assign (* "^=" *)
+ | Oshl_assign (* "<<=" *)
+ | Oshr_assign (* ">>=" *)
+ | Ocomma (* "," *)
+ | Ologand (* "&&" *)
+ | Ologor (* "||" *)
+
+(** Types *)
+
+type typ =
+ | TVoid of attributes
+ | TInt of ikind * attributes
+ | TFloat of fkind * attributes
+ | TPtr of typ * attributes
+ | TArray of typ * int64 option * attributes
+ | TFun of typ * (ident * typ) list option * bool * attributes
+ | TNamed of ident * attributes
+ | TStruct of ident * attributes
+ | TUnion of ident * attributes
+
+(** Expressions *)
+
+type exp = { edesc: exp_desc; etyp: typ }
+
+and exp_desc =
+ | EConst of constant
+ | ESizeof of typ
+ | EVar of ident
+ | EUnop of unary_operator * exp
+ | EBinop of binary_operator * exp * exp * typ
+ (* the type at which the operation is performed *)
+ | EConditional of exp * exp * exp
+ | ECast of typ * exp
+ | ECall of exp * exp list
+
+(** Statements *)
+
+type stmt = { sdesc: stmt_desc; sloc: location }
+
+and stmt_desc =
+ | Sskip
+ | Sdo of exp
+ | Sseq of stmt * stmt
+ | Sif of exp * stmt * stmt
+ | Swhile of exp * stmt
+ | Sdowhile of stmt * exp
+ | Sfor of stmt * exp * stmt * stmt
+ | Sbreak
+ | Scontinue
+ | Sswitch of exp * stmt
+ | Slabeled of slabel * stmt
+ | Sgoto of string
+ | Sreturn of exp option
+ | Sblock of stmt list
+ | Sdecl of decl
+
+and slabel =
+ | Slabel of string
+ | Scase of exp
+ | Sdefault
+
+(** Declarations *)
+
+and decl =
+ storage * ident * typ * init option
+
+(** Initializers *)
+
+and init =
+ | Init_single of exp
+ | Init_array of init list
+ | Init_struct of ident * (field * init) list
+ | Init_union of ident * field * init
+
+(** Struct or union field *)
+
+and field = {
+ fld_name: string;
+ fld_typ: typ;
+ fld_bitfield: int option
+}
+
+type struct_or_union =
+ | Struct
+ | Union
+
+(** Function definitions *)
+
+type fundef = {
+ fd_storage: storage;
+ fd_inline: bool;
+ fd_name: ident;
+ fd_ret: typ; (* return type *)
+ fd_params: (ident * typ) list; (* formal parameters *)
+ fd_vararg: bool; (* variable arguments? *)
+ fd_locals: decl list; (* local variables *)
+ fd_body: stmt
+}
+
+(** Global declarations *)
+
+type globdecl =
+ { gdesc: globdecl_desc; gloc: location }
+
+and globdecl_desc =
+ | Gdecl of decl (* variable declaration, function prototype *)
+ | Gfundef of fundef (* function definition *)
+ | Gcompositedecl of struct_or_union * ident (* struct/union declaration *)
+ | Gcompositedef of struct_or_union * ident * field list
+ (* struct/union definition *)
+ | Gtypedef of ident * typ (* typedef *)
+ | Genumdef of ident * (ident * exp option) list (* enum definition *)
+ | Gpragma of string (* #pragma directive *)
+
+type program = globdecl list
--- /dev/null
+include GCC
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * 3. The names of the contributors may not be used to endorse or promote
+ * products derived from this software without specific prior written
+ * permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ *)
+
+(** This file was originally part of Hugues Casee's frontc 2.0, and has been
+ * extensively changed since.
+**
+** 1.0 3.22.99 Hugues Cassé First version.
+** 2.0 George Necula 12/12/00: Many extensions
+ **)
+
+(*
+** Types
+*)
+
+type cabsloc = {
+ lineno : int;
+ filename: string;
+ byteno: int;
+ ident : int;
+}
+
+type typeSpecifier = (* Merge all specifiers into one type *)
+ Tvoid (* Type specifier ISO 6.7.2 *)
+ | Tchar
+ | Tshort
+ | Tint
+ | Tlong
+ | Tint64
+ | T_Bool
+ | Tfloat
+ | Tdouble
+ | Tsigned
+ | Tunsigned
+ | Tnamed of string
+ (* each of the following three kinds of specifiers contains a field
+ * or item list iff it corresponds to a definition (as opposed to
+ * a forward declaration or simple reference to the type); they
+ * also have a list of __attribute__s that appeared between the
+ * keyword and the type name (definitions only) *)
+ | Tstruct of string * field_group list option * attribute list
+ | Tunion of string * field_group list option * attribute list
+ | Tenum of string * enum_item list option * attribute list
+ | TtypeofE of expression (* GCC __typeof__ *)
+ | TtypeofT of specifier * decl_type (* GCC __typeof__ *)
+
+and storage =
+ NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER
+
+and funspec =
+ INLINE | VIRTUAL | EXPLICIT
+
+and cvspec =
+ CV_CONST | CV_VOLATILE | CV_RESTRICT
+
+(* Type specifier elements. These appear at the start of a declaration *)
+(* Everywhere they appear in this file, they appear as a 'spec_elem list', *)
+(* which is not interpreted by cabs -- rather, this "word soup" is passed *)
+(* on to the compiler. Thus, we can represent e.g. 'int long float x' even *)
+(* though the compiler will of course choke. *)
+and spec_elem =
+ SpecTypedef
+ | SpecCV of cvspec (* const/volatile *)
+ | SpecAttr of attribute (* __attribute__ *)
+ | SpecStorage of storage
+ | SpecInline
+ | SpecType of typeSpecifier
+
+(* decided to go ahead and replace 'spec_elem list' with specifier *)
+and specifier = spec_elem list
+
+
+(* Declarator type. They modify the base type given in the specifier. Keep
+ * them in the order as they are printed (this means that the top level
+ * constructor for ARRAY and PTR is the inner-level in the meaning of the
+ * declared type) *)
+and decl_type =
+ | JUSTBASE (* Prints the declared name *)
+ | PARENTYPE of attribute list * decl_type * attribute list
+ (* Prints "(attrs1 decl attrs2)".
+ * attrs2 are attributes of the
+ * declared identifier and it is as
+ * if they appeared at the very end
+ * of the declarator. attrs1 can
+ * contain attributes for the
+ * identifier or attributes for the
+ * enclosing type. *)
+ | ARRAY of decl_type * attribute list * expression
+ (* Prints "decl [ attrs exp ]".
+ * decl is never a PTR. *)
+ | PTR of attribute list * decl_type (* Prints "* attrs decl" *)
+ | PROTO of decl_type * single_name list * bool
+ (* Prints "decl (args[, ...])".
+ * decl is never a PTR.*)
+
+(* The base type and the storage are common to all names. Each name might
+ * contain type or storage modifiers *)
+(* e.g.: int x, y; *)
+and name_group = specifier * name list
+
+(* The optional expression is the bitfield *)
+and field_group = specifier * (name * expression option) list
+
+(* like name_group, except the declared variables are allowed to have initializers *)
+(* e.g.: int x=1, y=2; *)
+and init_name_group = specifier * init_name list
+
+(* The decl_type is in the order in which they are printed. Only the name of
+ * the declared identifier is pulled out. The attributes are those that are
+ * printed after the declarator *)
+(* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *)
+(* the string, and decl_type will be PTR([], JUSTBASE) *)
+and name = string * decl_type * attribute list * cabsloc
+
+(* A variable declarator ("name") with an initializer *)
+and init_name = name * init_expression
+
+(* Single names are for declarations that cannot come in groups, like
+ * function parameters and functions *)
+and single_name = specifier * name
+
+
+and enum_item = string * expression * cabsloc
+
+(*
+** Declaration definition (at toplevel)
+*)
+and definition =
+ FUNDEF of single_name * block * cabsloc * cabsloc
+ | DECDEF of init_name_group * cabsloc (* global variable(s), or function prototype *)
+ | TYPEDEF of name_group * cabsloc
+ | ONLYTYPEDEF of specifier * cabsloc
+ | GLOBASM of string * cabsloc
+ | PRAGMA of string * cabsloc
+ | LINKAGE of string * cabsloc * definition list (* extern "C" { ... } *)
+
+(* the string is a file name, and then the list of toplevel forms *)
+and file = string * definition list
+
+
+(*
+** statements
+*)
+
+(* A block contains a list of local label declarations ( GCC's ({ __label__
+ * l1, l2; ... }) ) , a list of definitions and a list of statements *)
+and block =
+ { blabels: string list;
+ battrs: attribute list;
+ bstmts: statement list
+ }
+
+(* GCC asm directives have lots of extra information to guide the optimizer *)
+and asm_details =
+ { aoutputs: (string option * string * expression) list; (* optional name, constraints and expressions for outputs *)
+ ainputs: (string option * string * expression) list; (* optional name, constraints and expressions for inputs *)
+ aclobbers: string list (* clobbered registers *)
+ }
+
+and statement =
+ NOP of cabsloc
+ | COMPUTATION of expression * cabsloc
+ | BLOCK of block * cabsloc
+(* | SEQUENCE of statement * statement * cabsloc *)
+ | IF of expression * statement * statement * cabsloc
+ | WHILE of expression * statement * cabsloc
+ | DOWHILE of expression * statement * cabsloc
+ | FOR of for_clause * expression * expression * statement * cabsloc
+ | BREAK of cabsloc
+ | CONTINUE of cabsloc
+ | RETURN of expression * cabsloc
+ | SWITCH of expression * statement * cabsloc
+ | CASE of expression * statement * cabsloc
+ | CASERANGE of expression * expression * statement * cabsloc
+ | DEFAULT of statement * cabsloc
+ | LABEL of string * statement * cabsloc
+ | GOTO of string * cabsloc
+ | COMPGOTO of expression * cabsloc (* GCC's "goto *exp" *)
+ | DEFINITION of definition (*definition or declaration of a variable or type*)
+
+ | ASM of attribute list * (* typically only volatile and const *)
+ string list * (* template *)
+ asm_details option * (* extra details to guide GCC's optimizer *)
+ cabsloc
+
+ (** MS SEH *)
+ | TRY_EXCEPT of block * expression * block * cabsloc
+ | TRY_FINALLY of block * block * cabsloc
+
+and for_clause =
+ FC_EXP of expression
+ | FC_DECL of definition
+
+(*
+** Expressions
+*)
+and binary_operator =
+ ADD | SUB | MUL | DIV | MOD
+ | AND | OR
+ | BAND | BOR | XOR | SHL | SHR
+ | EQ | NE | LT | GT | LE | GE
+ | ASSIGN
+ | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN
+ | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN
+
+and unary_operator =
+ MINUS | PLUS | NOT | BNOT | MEMOF | ADDROF
+ | PREINCR | PREDECR | POSINCR | POSDECR
+
+and expression =
+ NOTHING
+ | UNARY of unary_operator * expression
+ | LABELADDR of string (* GCC's && Label *)
+ | BINARY of binary_operator * expression * expression
+ | QUESTION of expression * expression * expression
+
+ (* A CAST can actually be a constructor expression *)
+ | CAST of (specifier * decl_type) * init_expression
+
+ (* There is a special form of CALL in which the function called is
+ __builtin_va_arg and the second argument is sizeof(T). This
+ should be printed as just T *)
+ | CALL of expression * expression list
+ | COMMA of expression list
+ | CONSTANT of constant
+ | PAREN of expression
+ | VARIABLE of string
+ | EXPR_SIZEOF of expression
+ | TYPE_SIZEOF of specifier * decl_type
+ | EXPR_ALIGNOF of expression
+ | TYPE_ALIGNOF of specifier * decl_type
+ | INDEX of expression * expression
+ | MEMBEROF of expression * string
+ | MEMBEROFPTR of expression * string
+ | GNU_BODY of block
+
+and constant =
+ | CONST_INT of string (* the textual representation *)
+ | CONST_FLOAT of string (* the textual representaton *)
+ | CONST_CHAR of int64 list
+ | CONST_WCHAR of int64 list
+ | CONST_STRING of string
+ | CONST_WSTRING of int64 list
+ (* ww: wstrings are stored as an int64 list at this point because
+ * we might need to feed the wide characters piece-wise into an
+ * array initializer (e.g., wchar_t foo[] = L"E\xabcd";). If that
+ * doesn't happen we will convert it to an (escaped) string before
+ * passing it to Cil. *)
+
+and init_expression =
+ | NO_INIT
+ | SINGLE_INIT of expression
+ | COMPOUND_INIT of (initwhat * init_expression) list
+
+and initwhat =
+ NEXT_INIT
+ | INFIELD_INIT of string * initwhat
+ | ATINDEX_INIT of expression * initwhat
+ | ATINDEXRANGE_INIT of expression * expression
+
+
+ (* Each attribute has a name and some
+ * optional arguments *)
+and attribute = string * expression list
+
+
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+
+open Cabs
+
+let nextident = ref 0
+let getident () =
+ nextident := !nextident + 1;
+ !nextident
+
+let currentLoc_lexbuf lb =
+ let p = Lexing.lexeme_start_p lb in
+ { lineno = p.Lexing.pos_lnum;
+ filename = p.Lexing.pos_fname;
+ byteno = p.Lexing.pos_cnum;
+ ident = getident ();}
+
+let currentLoc () =
+ let p = Parsing.symbol_start_pos() in
+ { lineno = p.Lexing.pos_lnum;
+ filename = p.Lexing.pos_fname;
+ byteno = p.Lexing.pos_cnum;
+ ident = getident ();}
+
+let cabslu = {lineno = -10;
+ filename = "cabs loc unknown";
+ byteno = -10;
+ ident = 0}
+
+(*********** HELPER FUNCTIONS **********)
+
+let missingFieldDecl = ("___missing_field_name", JUSTBASE, [], cabslu)
+
+let rec isStatic = function
+ [] -> false
+ | (SpecStorage STATIC) :: _ -> true
+ | _ :: rest -> isStatic rest
+
+let rec isExtern = function
+ [] -> false
+ | (SpecStorage EXTERN) :: _ -> true
+ | _ :: rest -> isExtern rest
+
+let rec isInline = function
+ [] -> false
+ | SpecInline :: _ -> true
+ | _ :: rest -> isInline rest
+
+let rec isTypedef = function
+ [] -> false
+ | SpecTypedef :: _ -> true
+ | _ :: rest -> isTypedef rest
+
+
+let get_definitionloc (d : definition) : cabsloc =
+ match d with
+ | FUNDEF(_, _, l, _) -> l
+ | DECDEF(_, l) -> l
+ | TYPEDEF(_, l) -> l
+ | ONLYTYPEDEF(_, l) -> l
+ | GLOBASM(_, l) -> l
+ | PRAGMA(_, l) -> l
+ | LINKAGE (_, l, _) -> l
+
+let get_statementloc (s : statement) : cabsloc =
+begin
+ match s with
+ | NOP(loc) -> loc
+ | COMPUTATION(_,loc) -> loc
+ | BLOCK(_,loc) -> loc
+(* | SEQUENCE(_,_,loc) -> loc *)
+ | IF(_,_,_,loc) -> loc
+ | WHILE(_,_,loc) -> loc
+ | DOWHILE(_,_,loc) -> loc
+ | FOR(_,_,_,_,loc) -> loc
+ | BREAK(loc) -> loc
+ | CONTINUE(loc) -> loc
+ | RETURN(_,loc) -> loc
+ | SWITCH(_,_,loc) -> loc
+ | CASE(_,_,loc) -> loc
+ | CASERANGE(_,_,_,loc) -> loc
+ | DEFAULT(_,loc) -> loc
+ | LABEL(_,_,loc) -> loc
+ | GOTO(_,loc) -> loc
+ | COMPGOTO (_, loc) -> loc
+ | DEFINITION d -> get_definitionloc d
+ | ASM(_,_,_,loc) -> loc
+ | TRY_EXCEPT(_, _, _, loc) -> loc
+ | TRY_FINALLY(_, _, loc) -> loc
+end
+
+
+let explodeStringToInts (s: string) : int64 list =
+ let rec allChars i acc =
+ if i < 0 then acc
+ else allChars (i - 1) (Int64.of_int (Char.code (String.get s i)) :: acc)
+ in
+ allChars (-1 + String.length s) []
+
+let valueOfDigit chr =
+ let int_value =
+ match chr with
+ '0'..'9' -> (Char.code chr) - (Char.code '0')
+ | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10
+ | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10
+ | _ -> assert false in
+ Int64.of_int int_value
+
+let string_of_cabsloc l =
+ Printf.sprintf "%s:%d" l.filename l.lineno
+
+let format_cabsloc pp l =
+ Format.fprintf pp "%s:%d" l.filename l.lineno
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Evaluation of compile-time constants *)
+
+open C
+open Cutil
+open Machine
+
+(* Extra arith on int64 *)
+
+external int64_unsigned_to_float: int64 -> float
+ = "cparser_int64_unsigned_to_float"
+external int64_unsigned_div: int64 -> int64 -> int64
+ = "cparser_int64_unsigned_div"
+external int64_unsigned_mod: int64 -> int64 -> int64
+ = "cparser_int64_unsigned_mod"
+external int64_unsigned_compare: int64 -> int64 -> int
+ = "cparser_int64_unsigned_compare"
+
+exception Notconst
+
+(* Reduce n to the range of representable integers of the given kind *)
+
+let normalize_int n ik =
+ if ik = IBool then
+ if n = 0L then 0L else 1L
+ else begin
+ let bitsize = sizeof_ikind ik * 8
+ and signed = is_signed_ikind ik in
+ if bitsize >= 64 then n else begin
+ let a = 64 - bitsize in
+ let p = Int64.shift_left n a in
+ if signed
+ then Int64.shift_right p a
+ else Int64.shift_right_logical p a
+ end
+ end
+
+(* Reduce n to the range of representable floats of the given kind *)
+
+let normalize_float f fk =
+ match fk with
+ | FFloat -> Int32.float_of_bits (Int32.bits_of_float f)
+ | FDouble -> f
+ | FLongDouble -> raise Notconst (* cannot accurately compute on this type *)
+
+type value =
+ | I of int64
+ | F of float
+ | S of string
+ | WS of int64 list
+
+let boolean_value v =
+ match v with
+ | I n -> n <> 0L
+ | F n -> n <> 0.0
+ | S _ | WS _ -> true
+
+let constant = function
+ | CInt(v, ik, _) -> I (normalize_int v ik)
+ | CFloat(v, fk, _) -> F (normalize_float v fk)
+ | CStr s -> S s
+ | CWStr s -> WS s
+ | CEnum(id, v) -> I v
+
+let is_signed env ty =
+ match unroll env ty with
+ | TInt(ik, _) -> is_signed_ikind ik
+ | _ -> false
+
+let cast env ty_to ty_from v =
+ match unroll env ty_to, v with
+ | TInt(IBool, _), _ ->
+ if boolean_value v then I 1L else I 0L
+ | TInt(ik, _), I n ->
+ I(normalize_int n ik)
+ | TInt(ik, _), F n ->
+ I(normalize_int (Int64.of_float n) ik)
+ | TInt(ik, _), (S _ | WS _) ->
+ if sizeof_ikind ik >= !config.sizeof_ptr
+ then v
+ else raise Notconst
+ | TFloat(fk, _), F n ->
+ F(normalize_float n fk)
+ | TFloat(fk, _), I n ->
+ if is_signed env ty_from
+ then F(normalize_float (Int64.to_float n) fk)
+ else F(normalize_float (int64_unsigned_to_float n) fk)
+ | TPtr(ty, _), I n ->
+ I (normalize_int n ptr_t_ikind)
+ | TPtr(ty, _), F n ->
+ if n = 0.0 then I 0L else raise Notconst
+ | TPtr(ty, _), (S _ | WS _) ->
+ v
+ | _, _ ->
+ raise Notconst
+
+let unop env op tyres ty v =
+ let res =
+ match op, tyres, v with
+ | Ominus, TInt _, I n -> I (Int64.neg n)
+ | Ominus, TFloat _, F n -> F (-. n)
+ | Oplus, TInt _, I n -> I n
+ | Oplus, TFloat _, F n -> F n
+ | Olognot, _, _ -> if boolean_value v then I 0L else I 1L
+ | _ -> raise Notconst
+ in cast env ty tyres res
+
+let comparison env direction ptraction tyop ty1 v1 ty2 v2 =
+ (* tyop = type at which the comparison is done *)
+ let b =
+ match cast env tyop ty1 v1, cast env tyop ty2 v2 with
+ | I n1, I n2 ->
+ if is_signed env tyop
+ then direction (compare n1 n2) 0
+ else direction (int64_unsigned_compare n1 n2) 0 (* including pointers *)
+ | F n1, F n2 ->
+ direction (compare n1 n2) 0
+ | (S _ | WS _), I 0L ->
+ begin match ptraction with None -> raise Notconst | Some b -> b end
+ | I 0L, (S _ | WS _) ->
+ begin match ptraction with None -> raise Notconst | Some b -> b end
+ | _, _ ->
+ raise Notconst
+ in if b then I 1L else I 0L
+
+let binop env op tyop tyres ty1 v1 ty2 v2 =
+ (* tyop = type at which the computation is done
+ tyres = expected result type *)
+ let res =
+ match op with
+ | Oadd ->
+ if is_arith_type env ty1 && is_arith_type env ty2 then begin
+ match cast env tyop ty1 v1, cast env tyop ty2 v2 with
+ | I n1, I n2 -> I (Int64.add n1 n2)
+ | F n1, F n2 -> F (n1 +. n2)
+ | _, _ -> raise Notconst
+ end else
+ raise Notconst
+ | Osub ->
+ if is_arith_type env ty1 && is_arith_type env ty2 then begin
+ match cast env tyop ty1 v1, cast env tyop ty2 v2 with
+ | I n1, I n2 -> I (Int64.sub n1 n2)
+ | F n1, F n2 -> F (n1 -. n2)
+ | _, _ -> raise Notconst
+ end else
+ raise Notconst
+ | Omul ->
+ begin match cast env tyop ty1 v1, cast env tyop ty2 v2 with
+ | I n1, I n2 -> I (Int64.mul n1 n2)
+ | F n1, F n2 -> F (n1 *. n2)
+ | _, _ -> raise Notconst
+ end
+ | Odiv ->
+ begin match cast env tyop ty1 v1, cast env tyop ty2 v2 with
+ | I n1, I n2 ->
+ if n2 = 0L then raise Notconst else
+ if is_signed env tyop then I (Int64.div n1 n2)
+ else I (int64_unsigned_div n1 n2)
+ | F n1, F n2 -> F (n1 /. n2)
+ | _, _ -> raise Notconst
+ end
+ | Omod ->
+ begin match v1, v2 with
+ | I n1, I n2 ->
+ if n2 = 0L then raise Notconst else
+ if is_signed env tyop then I (Int64.rem n1 n2)
+ else I (int64_unsigned_mod n1 n2)
+ | _, _ -> raise Notconst
+ end
+ | Oand ->
+ begin match v1, v2 with
+ | I n1, I n2 -> I (Int64.logand n1 n2)
+ | _, _ -> raise Notconst
+ end
+ | Oor ->
+ begin match v1, v2 with
+ | I n1, I n2 -> I (Int64.logor n1 n2)
+ | _, _ -> raise Notconst
+ end
+ | Oxor ->
+ begin match v1, v2 with
+ | I n1, I n2 -> I (Int64.logxor n1 n2)
+ | _, _ -> raise Notconst
+ end
+ | Oshl ->
+ begin match v1, v2 with
+ | I n1, I n2 when n2 >= 0L && n2 < 64L ->
+ I (Int64.shift_left n1 (Int64.to_int n2))
+ | _, _ -> raise Notconst
+ end
+ | Oshr ->
+ begin match v1, v2 with
+ | I n1, I n2 when n2 >= 0L && n2 < 64L ->
+ if is_signed env tyop
+ then I (Int64.shift_right n1 (Int64.to_int n2))
+ else I (Int64.shift_right_logical n1 (Int64.to_int n2))
+ | _, _ -> raise Notconst
+ end
+ | Oeq ->
+ comparison env (=) (Some false) tyop ty1 v1 ty2 v2
+ | One ->
+ comparison env (<>) (Some true) tyop ty1 v1 ty2 v2
+ | Olt ->
+ comparison env (<) None tyop ty1 v1 ty2 v2
+ | Ogt ->
+ comparison env (>) None tyop ty1 v1 ty2 v2
+ | Ole ->
+ comparison env (<=) None tyop ty1 v1 ty2 v2
+ | Oge ->
+ comparison env (>=) None tyop ty1 v1 ty2 v2
+ | Ocomma ->
+ v2
+ | Ologand ->
+ if boolean_value v1
+ then if boolean_value v2 then I 1L else I 0L
+ else I 0L
+ | Ologor ->
+ if boolean_value v1
+ then I 1L
+ else if boolean_value v2 then I 1L else I 0L
+ | _ -> raise Notconst
+ (* force normalization of result, e.g. of double to float *)
+ in cast env tyres tyres res
+
+let rec expr env e =
+ match e.edesc with
+ | EConst c ->
+ constant c
+ | ESizeof ty ->
+ begin match sizeof env ty with
+ | None -> raise Notconst
+ | Some n -> I(Int64.of_int n)
+ end
+ | EVar _ ->
+ raise Notconst
+ | EUnop(op, e1) ->
+ unop env op e.etyp e1.etyp (expr env e1)
+ | EBinop(op, e1, e2, ty) ->
+ binop env op ty e.etyp e1.etyp (expr env e1) e2.etyp (expr env e2)
+ | EConditional(e1, e2, e3) ->
+ if boolean_value (expr env e1) then expr env e2 else expr env e3
+ | ECast(ty, e1) ->
+ cast env e1.etyp ty (expr env e1)
+ | ECall _ ->
+ raise Notconst
+
+let integer_expr env e =
+ try
+ match cast env e.etyp (TInt(ILongLong, [])) (expr env e) with
+ | I n -> Some n
+ | _ -> None
+ with Notconst -> None
+
+let constant_expr env ty e =
+ try
+ match unroll env ty, cast env e.etyp ty (expr env e) with
+ | TInt(ik, _), I n -> Some(CInt(n, ik, ""))
+ | TFloat(fk, _), F n -> Some(CFloat(n, fk, ""))
+ | TPtr(_, _), I 0L -> Some(CInt(0L, IInt, ""))
+ | TPtr(_, _), S s -> Some(CStr s)
+ | TPtr(_, _), WS s -> Some(CWStr s)
+ | _ -> None
+ with Notconst -> None
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val integer_expr : Env.t -> C.exp -> int64 option
+val constant_expr : Env.t -> C.typ -> C.exp -> C.constant option
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Removing unused declarations *)
+
+open C
+open Cutil
+
+(* The set of all identifiers referenced so far *)
+let referenced = ref IdentSet.empty
+
+(* Record that a new identifier was added to this set *)
+let ref_changed = ref false
+
+(* Record a reference to an identifier. If seen for the first time,
+ add it to worklist. *)
+
+let addref id =
+ if not (IdentSet.mem id !referenced) then begin
+(* Printf.printf "Referenced: %s$%d\n" id.name id.stamp; *)
+ referenced := IdentSet.add id !referenced;
+ ref_changed := true
+ end
+
+let needed id =
+ IdentSet.mem id !referenced
+
+(* Iterate [addref] on all syntactic categories. *)
+
+let rec add_typ = function
+ | TPtr(ty, _) -> add_typ ty
+ | TArray(ty, _, _) -> add_typ ty
+ | TFun(res, None, _, _) -> add_typ res
+ | TFun(res, Some params, _, _) -> add_typ res; add_vars params
+ | TNamed(id, _) -> addref id
+ | TStruct(id, _) -> addref id
+ | TUnion(id, _) -> addref id
+ | _ -> ()
+
+and add_vars vl =
+ List.iter (fun (id, ty) -> add_typ ty) vl
+
+let rec add_exp e =
+ add_typ e.etyp; (* perhaps not necessary but play it safe *)
+ match e.edesc with
+ | EConst (CEnum(id, v)) -> addref id
+ | EConst _ -> ()
+ | ESizeof ty -> add_typ ty
+ | EVar id -> addref id
+ | EUnop(op, e1) -> add_exp e1
+ | EBinop(op, e1, e2, ty) -> add_exp e1; add_exp e2
+ | EConditional(e1, e2, e3) -> add_exp e1; add_exp e2; add_exp e3
+ | ECast(ty, e1) -> add_typ ty; add_exp e1
+ | ECall(e1, el) -> add_exp e1; List.iter add_exp el
+
+let rec add_init = function
+ | Init_single e -> add_exp e
+ | Init_array il -> List.iter add_init il
+ | Init_struct(id, il) -> addref id; List.iter (fun (_, i) -> add_init i) il
+ | Init_union(id, _, i) -> addref id; add_init i
+
+let add_decl (sto, id, ty, init) =
+ add_typ ty;
+ match init with None -> () | Some i -> add_init i
+
+let rec add_stmt s =
+ match s.sdesc with
+ | Sskip -> ()
+ | Sdo e -> add_exp e
+ | Sseq(s1, s2) -> add_stmt s1; add_stmt s2
+ | Sif(e, s1, s2) -> add_exp e; add_stmt s1; add_stmt s2
+ | Swhile(e, s1) -> add_exp e; add_stmt s1
+ | Sdowhile(s1, e) -> add_stmt s1; add_exp e
+ | Sfor(e1, e2, e3, s1) -> add_stmt e1; add_exp e2; add_stmt e3; add_stmt s1
+ | Sbreak -> ()
+ | Scontinue -> ()
+ | Sswitch(e, s1) -> add_exp e; add_stmt s1
+ | Slabeled(lbl, s) ->
+ begin match lbl with Scase e -> add_exp e | _ -> () end;
+ add_stmt s
+ | Sgoto lbl -> ()
+ | Sreturn None -> ()
+ | Sreturn(Some e) -> add_exp e
+ | Sblock sl -> List.iter add_stmt sl
+ | Sdecl d -> add_decl d
+
+let add_fundef f =
+ add_typ f.fd_ret;
+ add_vars f.fd_params;
+ List.iter add_decl f.fd_locals;
+ add_stmt f.fd_body
+
+let add_field f = add_typ f.fld_typ
+
+let add_enum e =
+ List.iter
+ (fun (id, opt_e) -> match opt_e with Some e -> add_exp e | None -> ())
+ e
+
+(* Saturate the set of referenced identifiers, starting with externally
+ visible global declarations *)
+
+let visible_decl (sto, id, ty, init) =
+ sto = Storage_default &&
+ match ty with TFun _ -> false | _ -> true
+
+let rec add_init_globdecls accu = function
+ | [] -> accu
+ | g :: rem ->
+ match g.gdesc with
+ | Gdecl decl when visible_decl decl ->
+ add_decl decl; add_init_globdecls accu rem
+ | Gfundef({fd_storage = Storage_default} as f) ->
+ add_fundef f; add_init_globdecls accu rem
+ | Gdecl _ | Gfundef _ | Gcompositedef _ | Gtypedef _ | Genumdef _ ->
+ (* Keep for later iterations *)
+ add_init_globdecls (g :: accu) rem
+ | Gcompositedecl _ | Gpragma _ ->
+ (* Discard, since these cannot introduce more references later *)
+ add_init_globdecls accu rem
+
+let rec add_needed_globdecls accu = function
+ | [] -> accu
+ | g :: rem ->
+ match g.gdesc with
+ | Gdecl((sto, id, ty, init) as decl) ->
+ if needed id
+ then (add_decl decl; add_needed_globdecls accu rem)
+ else add_needed_globdecls (g :: accu) rem
+ | Gfundef f ->
+ if needed f.fd_name
+ then (add_fundef f; add_needed_globdecls accu rem)
+ else add_needed_globdecls (g :: accu) rem
+ | Gcompositedef(_, id, flds) ->
+ if needed id
+ then (List.iter add_field flds; add_needed_globdecls accu rem)
+ else add_needed_globdecls (g :: accu) rem
+ | Gtypedef(id, ty) ->
+ if needed id
+ then (add_typ ty; add_needed_globdecls accu rem)
+ else add_needed_globdecls (g :: accu) rem
+ | Genumdef(id, enu) ->
+ if List.exists (fun (id, _) -> needed id) enu
+ then (add_enum enu; add_needed_globdecls accu rem)
+ else add_needed_globdecls (g :: accu) rem
+ | _ ->
+ assert false
+
+let saturate p =
+ let rec loop p =
+ if !ref_changed then begin
+ ref_changed := false;
+ loop (add_needed_globdecls [] p)
+ end in
+ ref_changed := false;
+ loop (add_init_globdecls [] p)
+
+(* Remove unreferenced definitions *)
+
+let rec simpl_globdecls accu = function
+ | [] -> accu
+ | g :: rem ->
+ let need =
+ match g.gdesc with
+ | Gdecl((sto, id, ty, init) as decl) -> visible_decl decl || needed id
+ | Gfundef f -> f.fd_storage = Storage_default || needed f.fd_name
+ | Gcompositedecl(_, id) -> needed id
+ | Gcompositedef(_, id, flds) -> needed id
+ | Gtypedef(id, ty) -> needed id
+ | Genumdef(id, enu) -> List.exists (fun (id, _) -> needed id) enu
+ | Gpragma s -> true in
+ if need
+ then simpl_globdecls (g :: accu) rem
+ else simpl_globdecls accu rem
+
+let program p =
+ referenced := IdentSet.empty;
+ saturate p;
+ let p' = simpl_globdecls [] p in
+ referenced := IdentSet.empty;
+ p'
+
+
+
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val program : C.program -> C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Pretty-printer for C abstract syntax *)
+
+open Format
+open C
+
+let print_idents_in_full = ref false
+
+let print_line_numbers = ref false
+
+let location pp (file, lineno) =
+ if !print_line_numbers && lineno >= 0 then
+ fprintf pp "# %d \"%s\"@ " lineno file
+
+let ident pp i =
+ if !print_idents_in_full
+ then fprintf pp "%s$%d" i.name i.stamp
+ else fprintf pp "%s" i.name
+
+let attribute pp = function
+ | AConst -> fprintf pp "const"
+ | AVolatile -> fprintf pp "volatile"
+ | ARestrict -> fprintf pp "restrict"
+
+let attributes pp = function
+ | [] -> ()
+ | al -> List.iter (fun a -> fprintf pp " %a" attribute a) al
+
+let name_of_ikind = function
+ | IBool -> "_Bool"
+ | IChar -> "char"
+ | ISChar -> "signed char"
+ | IUChar -> "unsigned char"
+ | IInt -> "int"
+ | IUInt -> "unsigned int"
+ | IShort -> "short"
+ | IUShort -> "unsigned short"
+ | ILong -> "long"
+ | IULong -> "unsigned long"
+ | ILongLong -> "long long"
+ | IULongLong -> "unsigned long long"
+
+let name_of_fkind = function
+ | FFloat -> "float"
+ | FDouble -> "double"
+ | FLongDouble -> "long double"
+
+let rec dcl pp ty n =
+ match ty with
+ | TVoid a ->
+ fprintf pp "void%a%t" attributes a n
+ | TInt(k, a) ->
+ fprintf pp "%s%a%t" (name_of_ikind k) attributes a n
+ | TFloat(k, a) ->
+ fprintf pp "%s%a%t" (name_of_fkind k) attributes a n
+ | TPtr(t, a) ->
+ let n' pp =
+ match t with
+ | TFun _ | TArray _ -> fprintf pp " (*%a%t)" attributes a n
+ | _ -> fprintf pp " *%a%t" attributes a n in
+ dcl pp t n'
+ | TArray(t, sz, a) ->
+ let n' pp =
+ begin match a with
+ | [] -> n pp
+ | _ -> fprintf pp " (%a%t)" attributes a n
+ end;
+ begin match sz with
+ | None -> fprintf pp "[]"
+ | Some i -> fprintf pp "[%Ld]" i
+ end in
+ dcl pp t n'
+ | TFun(tres, args, vararg, a) ->
+ let param (id, ty) =
+ dcl pp ty
+ (fun pp -> fprintf pp " %a" ident id) in
+ let n' pp =
+ begin match a with
+ | [] -> n pp
+ | _ -> fprintf pp " (%a%t)" attributes a n
+ end;
+ fprintf pp "(@[<hov 0>";
+ begin match args with
+ | None -> ()
+ | Some [] -> if vararg then fprintf pp "..." else fprintf pp "void"
+ | Some (a1 :: al) ->
+ param a1;
+ List.iter (fun a -> fprintf pp ",@ "; param a) al;
+ if vararg then fprintf pp ",@ ..."
+ end;
+ fprintf pp "@])" in
+ dcl pp tres n'
+ | TNamed(id, a) ->
+ fprintf pp "%a%a%t" ident id attributes a n
+ | TStruct(id, a) ->
+ fprintf pp "struct %a%a%t" ident id attributes a n
+ | TUnion(id, a) ->
+ fprintf pp "union %a%a%t" ident id attributes a n
+
+let typ pp ty =
+ dcl pp ty (fun _ -> ())
+
+let const pp = function
+ | CInt(v, ik, s) ->
+ if s <> "" then
+ fprintf pp "%s" s
+ else begin
+ fprintf pp "%Ld" v;
+ match ik with
+ | IULongLong -> fprintf pp "ULL"
+ | ILongLong -> fprintf pp "LL"
+ | IULong -> fprintf pp "UL"
+ | ILong -> fprintf pp "L"
+ | IUInt -> fprintf pp "U"
+ | _ -> ()
+ end
+ | CFloat(v, fk, s) ->
+ if s <> "" then
+ fprintf pp "%s" s
+ else begin
+ fprintf pp "%.18g" v;
+ match fk with
+ | FFloat -> fprintf pp "F"
+ | FLongDouble -> fprintf pp "L"
+ | _ -> ()
+ end
+ | CStr s ->
+ fprintf pp "\"";
+ for i = 0 to String.length s - 1 do
+ match s.[i] with
+ | '\009' -> fprintf pp "\\t"
+ | '\010' -> fprintf pp "\\n"
+ | '\013' -> fprintf pp "\\r"
+ | '\"' -> fprintf pp "\\\""
+ | '\\' -> fprintf pp "\\\\"
+ | c ->
+ if c >= ' ' && c <= '~'
+ then fprintf pp "%c" c
+ else fprintf pp "\\%03o" (Char.code c)
+ done;
+ fprintf pp "\""
+ | CWStr l ->
+ fprintf pp "L\"";
+ List.iter
+ (fun c ->
+ if c >= 32L && c <= 126L && c <> 34L && c <>92L
+ then fprintf pp "%c" (Char.chr (Int64.to_int c))
+ else fprintf pp "\" \"\\x%02Lx\" \"" c)
+ l;
+ fprintf pp "\""
+ | CEnum(id, v) ->
+ ident pp id
+
+type associativity = LtoR | RtoL | NA
+
+let precedence = function (* H&S section 7.2 *)
+ | EConst _ -> (16, NA)
+ | ESizeof _ -> (15, RtoL)
+ | EVar _ -> (16, NA)
+ | EBinop(Oindex, _, _, _) -> (16, LtoR)
+ | ECall _ -> (16, LtoR)
+ | EUnop((Odot _|Oarrow _), _) -> (16, LtoR)
+ | EUnop((Opostincr|Opostdecr), _) -> (16, LtoR)
+ | EUnop((Opreincr|Opredecr|Onot|Olognot|Ominus|Oplus|Oaddrof|Oderef), _) -> (15, RtoL)
+ | ECast _ -> (14, RtoL)
+ | EBinop((Omul|Odiv|Omod), _, _, _) -> (13, LtoR)
+ | EBinop((Oadd|Osub), _, _, _) -> (12, LtoR)
+ | EBinop((Oshl|Oshr), _, _, _) -> (11, LtoR)
+ | EBinop((Olt|Ogt|Ole|Oge), _, _, _) -> (10, LtoR)
+ | EBinop((Oeq|One), _, _, _) -> (9, LtoR)
+ | EBinop(Oand, _, _, _) -> (8, LtoR)
+ | EBinop(Oxor, _, _, _) -> (7, LtoR)
+ | EBinop(Oor, _, _, _) -> (6, LtoR)
+ | EBinop(Ologand, _, _, _) -> (5, LtoR)
+ | EBinop(Ologor, _, _, _) -> (4, LtoR)
+ | EConditional _ -> (3, RtoL)
+ | EBinop((Oassign|Oadd_assign|Osub_assign|Omul_assign|Odiv_assign|Omod_assign|Oand_assign|Oor_assign|Oxor_assign|Oshl_assign|Oshr_assign), _, _, _) -> (2, RtoL)
+ | EBinop(Ocomma, _, _, _) -> (1, LtoR)
+
+let rec exp pp (prec, a) =
+ let (prec', assoc) = precedence a.edesc in
+ let (prec1, prec2) =
+ if assoc = LtoR
+ then (prec', prec' + 1)
+ else (prec' + 1, prec') in
+ if prec' < prec
+ then fprintf pp "@[<hov 2>("
+ else fprintf pp "@[<hov 2>";
+ begin match a.edesc with
+ | EConst cst -> const pp cst
+ | EVar id -> ident pp id
+ | ESizeof ty -> fprintf pp "sizeof(%a)" typ ty
+ | EUnop(Ominus, a1) ->
+ fprintf pp "-%a" exp (prec', a1)
+ | EUnop(Oplus, a1) ->
+ fprintf pp "+%a" exp (prec', a1)
+ | EUnop(Olognot, a1) ->
+ fprintf pp "!%a" exp (prec', a1)
+ | EUnop(Onot, a1) ->
+ fprintf pp "~%a" exp (prec', a1)
+ | EUnop(Oderef, a1) ->
+ fprintf pp "*%a" exp (prec', a1)
+ | EUnop(Oaddrof, a1) ->
+ fprintf pp "&%a" exp (prec', a1)
+ | EUnop(Opreincr, a1) ->
+ fprintf pp "++%a" exp (prec', a1)
+ | EUnop(Opredecr, a1) ->
+ fprintf pp "--%a" exp (prec', a1)
+ | EUnop(Opostincr, a1) ->
+ fprintf pp "%a++" exp (prec', a1)
+ | EUnop(Opostdecr, a1) ->
+ fprintf pp "%a--" exp (prec', a1)
+ | EUnop(Odot s, a1) ->
+ fprintf pp "%a.%s" exp (prec', a1)s
+ | EUnop(Oarrow s, a1) ->
+ fprintf pp "%a->%s" exp (prec', a1)s
+ | EBinop(Oadd, a1, a2, _) ->
+ fprintf pp "%a@ + %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Osub, a1, a2, _) ->
+ fprintf pp "%a@ - %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Omul, a1, a2, _) ->
+ fprintf pp "%a@ * %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Odiv, a1, a2, _) ->
+ fprintf pp "%a@ / %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Omod, a1, a2, _) ->
+ fprintf pp "%a@ %% %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oand, a1, a2, _) ->
+ fprintf pp "%a@ & %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oor, a1, a2, _) ->
+ fprintf pp "%a@ | %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oxor, a1, a2, _) ->
+ fprintf pp "%a@ ^ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oshl, a1, a2, _) ->
+ fprintf pp "%a@ << %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oshr, a1, a2, _) ->
+ fprintf pp "%a@ >> %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oeq, a1, a2, _) ->
+ fprintf pp "%a@ == %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(One, a1, a2, _) ->
+ fprintf pp "%a@ != %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Olt, a1, a2, _) ->
+ fprintf pp "%a@ < %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Ogt, a1, a2, _) ->
+ fprintf pp "%a@ > %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Ole, a1, a2, _) ->
+ fprintf pp "%a@ <= %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oge, a1, a2, _) ->
+ fprintf pp "%a@ >= %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oindex, a1, a2, _) ->
+ fprintf pp "%a[%a]" exp (prec1, a1) exp (0, a2)
+ | EBinop(Oassign, a1, a2, _) ->
+ fprintf pp "%a =@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oadd_assign, a1, a2, _) ->
+ fprintf pp "%a +=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Osub_assign, a1, a2, _) ->
+ fprintf pp "%a -=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Omul_assign, a1, a2, _) ->
+ fprintf pp "%a *=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Odiv_assign, a1, a2, _) ->
+ fprintf pp "%a /=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Omod_assign, a1, a2, _) ->
+ fprintf pp "%a %%=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oand_assign, a1, a2, _) ->
+ fprintf pp "%a &=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oor_assign, a1, a2, _) ->
+ fprintf pp "%a |=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oxor_assign, a1, a2, _) ->
+ fprintf pp "%a ^=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oshl_assign, a1, a2, _) ->
+ fprintf pp "%a <<=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Oshr_assign, a1, a2, _) ->
+ fprintf pp "%a >>=@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Ocomma, a1, a2, _) ->
+ fprintf pp "%a,@ %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Ologand, a1, a2, _) ->
+ fprintf pp "%a@ && %a" exp (prec1, a1) exp (prec2, a2)
+ | EBinop(Ologor, a1, a2, _) ->
+ fprintf pp "%a@ || %a" exp (prec1, a1) exp (prec2, a2)
+ | EConditional(a1, a2, a3) ->
+ fprintf pp "%a@ ? %a@ : %a" exp (4, a1) exp (4, a2) exp (4, a3)
+ | ECast(ty, a1) ->
+ fprintf pp "(%a) %a" typ ty exp (prec', a1)
+ | ECall({edesc = EVar {name = "__builtin_va_start"}},
+ [a1; {edesc = EUnop(Oaddrof, a2)}]) ->
+ fprintf pp "__builtin_va_start@[<hov 1>(%a,@ %a)@]"
+ exp (2, a1) exp (2, a2)
+ | ECall({edesc = EVar {name = "__builtin_va_arg"}},
+ [a1; {edesc = ESizeof ty}]) ->
+ fprintf pp "__builtin_va_arg@[<hov 1>(%a,@ %a)@]"
+ exp (2, a1) typ ty
+ | ECall(a1, al) ->
+ fprintf pp "%a@[<hov 1>(" exp (prec', a1);
+ begin match al with
+ | [] -> ()
+ | a1 :: al ->
+ fprintf pp "%a" exp (2, a1);
+ List.iter (fun a -> fprintf pp ",@ %a" exp (2, a)) al
+ end;
+ fprintf pp ")@]"
+ end;
+ if prec' < prec then fprintf pp ")@]" else fprintf pp "@]"
+
+let rec init pp = function
+ | Init_single e ->
+ exp pp (2, e)
+ | Init_array il ->
+ fprintf pp "@[<hov 1>{";
+ List.iter (fun i -> fprintf pp "%a,@ " init i) il;
+ fprintf pp "}@]"
+ | Init_struct(id, il) ->
+ fprintf pp "@[<hov 1>{";
+ List.iter (fun (fld, i) -> fprintf pp "%a,@ " init i) il;
+ fprintf pp "}@]"
+ | Init_union(id, fld, i) ->
+ fprintf pp "@[<hov 1>{%a}@]" init i
+
+let simple_decl pp (id, ty) =
+ dcl pp ty (fun pp -> fprintf pp " %a" ident id)
+
+let storage pp = function
+ | Storage_default -> ()
+ | Storage_extern -> fprintf pp "extern "
+ | Storage_static -> fprintf pp "static "
+ | Storage_register -> fprintf pp "register "
+
+let full_decl pp (sto, id, ty, int) =
+ fprintf pp "@[<hov 2>%a" storage sto;
+ dcl pp ty (fun pp -> fprintf pp " %a" ident id);
+ begin match int with
+ | None -> ()
+ | Some i -> fprintf pp " =@ %a" init i
+ end;
+ fprintf pp ";@]"
+
+exception Not_expr
+
+let rec exp_of_stmt s =
+ match s.sdesc with
+ | Sdo e -> e
+ | Sseq(s1, s2) ->
+ {edesc = EBinop(Ocomma, exp_of_stmt s1, exp_of_stmt s2, TVoid []);
+ etyp = TVoid []}
+ | Sif(e, s1, s2) ->
+ {edesc = EConditional(e, exp_of_stmt s1, exp_of_stmt s2);
+ etyp = TVoid []}
+ | _ ->
+ raise Not_expr
+
+let rec stmt pp s =
+ location pp s.sloc;
+ match s.sdesc with
+ | Sskip ->
+ fprintf pp "/*skip*/;"
+ | Sdo e ->
+ fprintf pp "%a;" exp (0, e)
+ | Sseq(s1, s2) ->
+ fprintf pp "%a@ %a" stmt s1 stmt s2
+ | Sif(e, s1, {sdesc = Sskip}) ->
+ fprintf pp "@[<v 2>if (%a) {@ %a@;<0 -2>}@]"
+ exp (0, e) stmt_block s1
+ | Sif(e, {sdesc = Sskip}, s2) ->
+ let not_e = {edesc = EUnop(Olognot, e); etyp = TInt(IInt, [])} in
+ fprintf pp "@[<v 2>if (%a) {@ %a@;<0 -2>}@]"
+ exp (0, not_e) stmt_block s2
+ | Sif(e, s1, s2) ->
+ fprintf pp "@[<v 2>if (%a) {@ %a@;<0 -2>} else {@ %a@;<0 -2>}@]"
+ exp (0, e) stmt_block s1 stmt_block s2
+ | Swhile(e, s1) ->
+ fprintf pp "@[<v 2>while (%a) {@ %a@;<0 -2>}@]"
+ exp (0, e) stmt_block s1
+ | Sdowhile(s1, e) ->
+ fprintf pp "@[<v 2>do {@ %a@;<0 -2>} while(%a);@]"
+ stmt_block s1 exp (0, e)
+ | Sfor(e1, e2, e3, s1) ->
+ fprintf pp "@[<v 2>for (@[<hv 0>%a;@ %a;@ %a) {@]@ %a@;<0 -2>}@]"
+ opt_exp e1
+ exp (0, e2)
+ opt_exp e3
+ stmt_block s1
+ | Sbreak ->
+ fprintf pp "break;"
+ | Scontinue ->
+ fprintf pp "continue;"
+ | Sswitch(e, s1) ->
+ fprintf pp "@[<v 2>switch (%a) {@ %a@;<0 -2>}@]"
+ exp (0, e)
+ stmt_block s1
+ | Slabeled(lbl, s1) ->
+ fprintf pp "%a:@ %a" slabel lbl stmt s1
+ | Sgoto lbl ->
+ fprintf pp "goto %s;" lbl
+ | Sreturn None ->
+ fprintf pp "return;"
+ | Sreturn (Some e) ->
+ fprintf pp "return %a;" exp (0, e)
+ | Sblock sl ->
+ fprintf pp "@[<v 2>{@ %a@;<0 -2>}@]" stmt_block s
+ | Sdecl d ->
+ full_decl pp d
+
+and slabel pp = function
+ | Slabel s ->
+ fprintf pp "%s" s
+ | Scase e ->
+ fprintf pp "case %a" exp (0, e)
+ | Sdefault ->
+ fprintf pp "default"
+
+and stmt_block pp s =
+ match s.sdesc with
+ | Sblock [] -> ()
+ | Sblock (s1 :: sl) ->
+ stmt pp s1;
+ List.iter (fun s -> fprintf pp "@ %a" stmt s) sl
+ | _ ->
+ stmt pp s
+
+and opt_exp pp s =
+ if s.sdesc = Sskip then fprintf pp "/*nothing*/" else
+ try
+ exp pp (0, exp_of_stmt s)
+ with Not_expr ->
+ fprintf pp "@[<v 3>({ %a })@]" stmt s
+
+let fundef pp f =
+ fprintf pp "@[<hov 2>%s%a"
+ (if f.fd_inline then "inline " else "")
+ storage f.fd_storage;
+ simple_decl pp (f.fd_name, TFun(f.fd_ret, Some f.fd_params, f.fd_vararg, []));
+ fprintf pp "@]@ @[<v 2>{@ ";
+ List.iter (fun d -> fprintf pp "%a@ " full_decl d) f.fd_locals;
+ stmt_block pp f.fd_body;
+ fprintf pp "@;<0 -2>}@]@ @ "
+
+let field pp f =
+ simple_decl pp ({name = f.fld_name; stamp = 0}, f.fld_typ);
+ match f.fld_bitfield with
+ | None -> ()
+ | Some n -> fprintf pp " : %d" n
+
+let globdecl pp g =
+ location pp g.gloc;
+ match g.gdesc with
+ | Gdecl d ->
+ fprintf pp "%a@ @ " full_decl d
+ | Gfundef f ->
+ fundef pp f
+ | Gcompositedecl(kind, id) ->
+ fprintf pp "%s %a;@ @ "
+ (match kind with Struct -> "struct" | Union -> "union")
+ ident id
+ | Gcompositedef(kind, id, flds) ->
+ fprintf pp "@[<v 2>%s %a {"
+ (match kind with Struct -> "struct" | Union -> "union")
+ ident id;
+ List.iter (fun fld -> fprintf pp "@ %a;" field fld) flds;
+ fprintf pp "@;<0 -2>};@]@ @ "
+ | Gtypedef(id, ty) ->
+ fprintf pp "@[<hov 2>typedef %a;@]@ @ " simple_decl (id, ty)
+ | Genumdef(id, fields) ->
+ fprintf pp "@[<v 2>enum %a {" ident id;
+ List.iter
+ (fun (name, opt_e) ->
+ fprintf pp "@ %a" ident name;
+ begin match opt_e with
+ | None -> ()
+ | Some e -> fprintf pp " = %a" exp (0, e)
+ end;
+ fprintf pp ",")
+ fields;
+ fprintf pp "@;<0 -2>};@]@ @ "
+ | Gpragma s ->
+ fprintf pp "#pragma %s@ @ " s
+
+let program pp prog =
+ fprintf pp "@[<v 0>";
+ List.iter (globdecl pp) prog;
+ fprintf pp "@]@."
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val print_idents_in_full : bool ref
+val print_line_numbers : bool ref
+
+val location : Format.formatter -> C.location -> unit
+val typ : Format.formatter -> C.typ -> unit
+val simple_decl : Format.formatter -> C.ident * C.typ -> unit
+val full_decl: Format.formatter -> C.decl -> unit
+val const : Format.formatter -> C.constant -> unit
+val exp : Format.formatter -> int * C.exp -> unit
+val opt_exp : Format.formatter -> C.stmt -> unit
+val stmt : Format.formatter -> C.stmt -> unit
+val fundef : Format.formatter -> C.fundef -> unit
+val init : Format.formatter -> C.init -> unit
+val storage : Format.formatter -> C.storage -> unit
+val field : Format.formatter -> C.field -> unit
+val globdecl : Format.formatter -> C.globdecl -> unit
+val program : Format.formatter -> C.program -> unit
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Operations on C types and abstract syntax *)
+
+open Printf
+open Errors
+open C
+open Env
+open Machine
+
+(* Set and Map structures over identifiers *)
+
+module Ident = struct
+ type t = ident
+ let compare id1 id2 = Pervasives.compare id1.stamp id2.stamp
+end
+
+module IdentSet = Set.Make(Ident)
+module IdentMap = Map.Make(Ident)
+
+(* Operations on attributes *)
+
+(* Lists of attributes are kept sorted in increasing order *)
+
+let rec add_attributes (al1: attributes) (al2: attributes) =
+ match al1, al2 with
+ | [], _ -> al2
+ | _, [] -> al1
+ | a1 :: al1', a2 :: al2' ->
+ if a1 < a2 then a1 :: add_attributes al1' al2
+ else if a1 > a2 then a2 :: add_attributes al1 al2'
+ else a1 :: add_attributes al1' al2'
+
+let rec remove_attributes (al1: attributes) (al2: attributes) =
+ (* viewed as sets: al1 \ al2 *)
+ match al1, al2 with
+ | [], _ -> []
+ | _, [] -> al1
+ | a1 :: al1', a2 :: al2' ->
+ if a1 < a2 then a1 :: remove_attributes al1' al2
+ else if a1 > a2 then remove_attributes al1 al2'
+ else remove_attributes al1' al2'
+
+let rec incl_attributes (al1: attributes) (al2: attributes) =
+ match al1, al2 with
+ | [], _ -> true
+ | _ :: _, [] -> false
+ | a1 :: al1', a2 :: al2' ->
+ if a1 < a2 then false
+ else if a1 > a2 then incl_attributes al1 al2'
+ else incl_attributes al1' al2'
+
+(* Adding top-level attributes to a type. Doesn't need to unroll defns. *)
+(* Array types cannot carry attributes, so add them to the element type. *)
+
+let rec add_attributes_type attr t =
+ match t with
+ | TVoid a -> TVoid (add_attributes attr a)
+ | TInt(ik, a) -> TInt(ik, add_attributes attr a)
+ | TFloat(fk, a) -> TFloat(fk, add_attributes attr a)
+ | TPtr(ty, a) -> TPtr(ty, add_attributes attr a)
+ | TArray(ty, sz, a) -> TArray(add_attributes_type attr ty, sz, a)
+ | TFun(ty, params, vararg, a) -> TFun(ty, params, vararg, add_attributes attr
+a)
+ | TNamed(s, a) -> TNamed(s, add_attributes attr a)
+ | TStruct(s, a) -> TStruct(s, add_attributes attr a)
+ | TUnion(s, a) -> TUnion(s, add_attributes attr a)
+
+(* Unrolling of typedef *)
+
+let rec unroll env t =
+ match t with
+ | TNamed(name, attr) ->
+ let ty = Env.find_typedef env name in
+ unroll env (add_attributes_type attr ty)
+ | _ -> t
+
+(* Extracting the attributes of a type *)
+
+let rec attributes_of_type env t =
+ match t with
+ | TVoid a -> a
+ | TInt(ik, a) -> a
+ | TFloat(fk, a) -> a
+ | TPtr(ty, a) -> a
+ | TArray(ty, sz, a) -> a (* correct? *)
+ | TFun(ty, params, vararg, a) -> a
+ | TNamed(s, a) -> attributes_of_type env (unroll env t)
+ | TStruct(s, a) -> a
+ | TUnion(s, a) -> a
+
+(* Changing the attributes of a type (at top-level) *)
+(* Same hack as above for array types. *)
+
+let rec change_attributes_type env (f: attributes -> attributes) t =
+ match t with
+ | TVoid a -> TVoid (f a)
+ | TInt(ik, a) -> TInt(ik, f a)
+ | TFloat(fk, a) -> TFloat(fk, f a)
+ | TPtr(ty, a) -> TPtr(ty, f a)
+ | TArray(ty, sz, a) ->
+ TArray(change_attributes_type env f ty, sz, a)
+ | TFun(ty, params, vararg, a) -> TFun(ty, params, vararg, f a)
+ | TNamed(s, a) ->
+ let t1 = unroll env t in
+ let t2 = change_attributes_type env f t1 in
+ if t2 = t1 then t else t2 (* avoid useless expansion *)
+ | TStruct(s, a) -> TStruct(s, f a)
+ | TUnion(s, a) -> TUnion(s, f a)
+
+let remove_attributes_type env attr t =
+ change_attributes_type env (fun a -> remove_attributes a attr) t
+
+let erase_attributes_type env t =
+ change_attributes_type env (fun a -> []) t
+
+(* Type compatibility *)
+
+exception Incompat
+
+let combine_types ?(noattrs = false) env t1 t2 =
+
+ let comp_attr a1 a2 =
+ if a1 = a2 then a2
+ else if noattrs then add_attributes a1 a2
+ else raise Incompat
+ and comp_base x1 x2 =
+ if x1 = x2 then x2 else raise Incompat
+ and comp_array_size sz1 sz2 =
+ match sz1, sz2 with
+ | None, _ -> sz2
+ | _, None -> sz1
+ | Some n1, Some n2 -> if n1 = n2 then Some n2 else raise Incompat
+ and comp_conv (id, ty) =
+ match unroll env ty with
+ | TInt(kind, attr) ->
+ begin match kind with
+ | IBool | IChar | ISChar | IUChar | IShort | IUShort -> raise Incompat
+ | _ -> ()
+ end
+ | TFloat(kind, attr) ->
+ begin match kind with
+ | FFloat -> raise Incompat
+ | _ -> ()
+ end
+ | _ -> () in
+
+ let rec comp t1 t2 =
+ match t1, t2 with
+ | TVoid a1, TVoid a2 ->
+ TVoid(comp_attr a1 a2)
+ | TInt(ik1, a1), TInt(ik2, a2) ->
+ TInt(comp_base ik1 ik2, comp_attr a1 a2)
+ | TFloat(fk1, a1), TFloat(fk2, a2) ->
+ TFloat(comp_base fk1 fk2, comp_attr a1 a2)
+ | TPtr(ty1, a1), TPtr(ty2, a2) ->
+ TPtr(comp ty1 ty2, comp_attr a1 a2)
+ | TArray(ty1, sz1, a1), TArray(ty2, sz2, a2) ->
+ TArray(comp ty1 ty2, comp_array_size sz1 sz2, comp_attr a1 a2)
+ | TFun(ty1, params1, vararg1, a1), TFun(ty2, params2, vararg2, a2) ->
+ let (params, vararg) =
+ match params1, params2 with
+ | None, None -> None, false
+ | None, Some l2 -> List.iter comp_conv l2; (params2, vararg2)
+ | Some l1, None -> List.iter comp_conv l1; (params1, vararg1)
+ | Some l1, Some l2 ->
+ if List.length l1 <> List.length l2 then raise Incompat;
+ (Some(List.map2 (fun (id1, ty1) (id2, ty2) -> (id2, comp ty1 ty2))
+ l1 l2),
+ comp_base vararg1 vararg2)
+ in
+ TFun(comp ty1 ty2, params, vararg, comp_attr a1 a2)
+ | TNamed _, _ -> comp (unroll env t1) t2
+ | _, TNamed _ -> comp t1 (unroll env t2)
+ | TStruct(s1, a1), TStruct(s2, a2) ->
+ TStruct(comp_base s1 s2, comp_attr a1 a2)
+ | TUnion(s1, a1), TUnion(s2, a2) ->
+ TUnion(comp_base s1 s2, comp_attr a1 a2)
+ | _, _ ->
+ raise Incompat
+
+ in try Some(comp t1 t2) with Incompat -> None
+
+let compatible_types ?noattrs env t1 t2 =
+ match combine_types ?noattrs env t1 t2 with Some _ -> true | None -> false
+
+(* Naive placement algorithm for bit fields, might not match that
+ of the compiler. *)
+
+let pack_bitfields ml =
+ let rec pack nbits = function
+ | [] ->
+ (nbits, [])
+ | m :: ms as ml ->
+ match m.fld_bitfield with
+ | None -> (nbits, ml)
+ | Some n ->
+ if n = 0 then
+ (nbits, ms) (* bit width 0 means end of pack *)
+ else if nbits + n > 8 * !config.sizeof_int then
+ (nbits, ml) (* doesn't fit in current word *)
+ else
+ pack (nbits + n) ms (* add to current word *)
+ in
+ let (nbits, ml') = pack 0 ml in
+ let sz =
+ if nbits <= 8 then 1 else
+ if nbits <= 16 then 2 else
+ if nbits <= 32 then 4 else
+ if nbits <= 64 then 8 else assert false in
+ (sz, ml')
+
+(* Natural alignment, in bytes *)
+
+let alignof_ikind = function
+ | IBool | IChar | ISChar | IUChar -> 1
+ | IInt | IUInt -> !config.alignof_int
+ | IShort | IUShort -> !config.alignof_short
+ | ILong | IULong -> !config.alignof_long
+ | ILongLong | IULongLong -> !config.alignof_longlong
+
+let alignof_fkind = function
+ | FFloat -> !config.alignof_float
+ | FDouble -> !config.alignof_double
+ | FLongDouble -> !config.alignof_longdouble
+
+(* Return natural alignment of given type, or None if the type is incomplete *)
+
+let rec alignof env t =
+ match t with
+ | TVoid _ -> !config.alignof_void
+ | TInt(ik, _) -> Some(alignof_ikind ik)
+ | TFloat(fk, _) -> Some(alignof_fkind fk)
+ | TPtr(_, _) -> Some(!config.alignof_ptr)
+ | TArray(ty, _, _) -> alignof env ty
+ | TFun(_, _, _, _) -> !config.alignof_fun
+ | TNamed(_, _) -> alignof env (unroll env t)
+ | TStruct(name, _) ->
+ let ci = Env.find_struct env name in ci.ci_alignof
+ | TUnion(name, _) ->
+ let ci = Env.find_union env name in ci.ci_alignof
+
+(* Compute the natural alignment of a struct or union. *)
+
+let alignof_struct_union env members =
+ let rec align_rec al = function
+ | [] -> Some al
+ | m :: rem as ml ->
+ if m.fld_bitfield = None then begin
+ match alignof env m.fld_typ with
+ | None -> None
+ | Some a -> align_rec (max a al) rem
+ end else begin
+ let (sz, ml') = pack_bitfields ml in
+ align_rec (max sz al) ml'
+ end
+ in align_rec 1 members
+
+let align x boundary =
+ (* boundary must be a power of 2 *)
+ (x + boundary - 1) land (lnot (boundary - 1))
+
+(* Size of, in bytes *)
+
+let sizeof_ikind = function
+ | IBool | IChar | ISChar | IUChar -> 1
+ | IInt | IUInt -> !config.sizeof_int
+ | IShort | IUShort -> !config.sizeof_short
+ | ILong | IULong -> !config.sizeof_long
+ | ILongLong | IULongLong -> !config.sizeof_longlong
+
+let sizeof_fkind = function
+ | FFloat -> !config.sizeof_float
+ | FDouble -> !config.sizeof_double
+ | FLongDouble -> !config.sizeof_longdouble
+
+(* Overflow-avoiding multiplication of an int64 and an int, with
+ result in type int. *)
+
+let cautious_mul (a: int64) (b: int) =
+ if b = 0 || a <= Int64.of_int (max_int / b)
+ then Some(Int64.to_int a * b)
+ else None
+
+(* Return size of type, in bytes, or [None] if the type is incomplete *)
+
+let rec sizeof env t =
+ match t with
+ | TVoid _ -> !config.sizeof_void
+ | TInt(ik, _) -> Some(sizeof_ikind ik)
+ | TFloat(fk, _) -> Some(sizeof_fkind fk)
+ | TPtr(_, _) -> Some(!config.sizeof_ptr)
+ | TArray(ty, None, _) -> None
+ | TArray(ty, Some n, _) as t' ->
+ begin match sizeof env ty with
+ | None -> None
+ | Some s ->
+ match cautious_mul n s with
+ | Some sz -> Some sz
+ | None -> error "sizeof(%a) overflows" Cprint.typ t'; Some 1
+ end
+ | TFun(_, _, _, _) -> !config.sizeof_fun
+ | TNamed(_, _) -> sizeof env (unroll env t)
+ | TStruct(name, _) ->
+ let ci = Env.find_struct env name in ci.ci_sizeof
+ | TUnion(name, _) ->
+ let ci = Env.find_union env name in ci.ci_sizeof
+
+(* Compute the size of a union.
+ It is the size is the max of the sizes of fields, rounded up to the
+ natural alignment. *)
+
+let sizeof_union env members =
+ let rec sizeof_rec sz = function
+ | [] ->
+ begin match alignof_struct_union env members with
+ | None -> None (* should not happen? *)
+ | Some al -> Some (align sz al)
+ end
+ | m :: rem ->
+ begin match sizeof env m.fld_typ with
+ | None -> None
+ | Some s -> sizeof_rec (max sz s) rem
+ end
+ in sizeof_rec 0 members
+
+(* Compute the size of a struct.
+ We lay out fields consecutively, inserting padding to preserve
+ their natural alignment. *)
+
+let sizeof_struct env members =
+ let rec sizeof_rec ofs = function
+ | [] | [ { fld_typ = TArray(_, None, _) } ] ->
+ (* C99: ty[] allowed as last field *)
+ begin match alignof_struct_union env members with
+ | None -> None (* should not happen? *)
+ | Some al -> Some (align ofs al)
+ end
+ | m :: rem as ml ->
+ if m.fld_bitfield = None then begin
+ match alignof env m.fld_typ, sizeof env m.fld_typ with
+ | Some a, Some s -> sizeof_rec (align ofs a + s) rem
+ | _, _ -> None
+ end else begin
+ let (sz, ml') = pack_bitfields ml in
+ sizeof_rec (align ofs sz + sz) ml'
+ end
+ in sizeof_rec 0 members
+
+(* Determine whether a type is incomplete *)
+
+let incomplete_type env t =
+ match sizeof env t with None -> true | Some _ -> false
+
+(* Computing composite_info records *)
+
+let composite_info_decl env su =
+ { ci_kind = su; ci_members = []; ci_alignof = None; ci_sizeof = None }
+
+let composite_info_def env su m =
+ { ci_kind = su; ci_members = m;
+ ci_alignof = alignof_struct_union env m;
+ ci_sizeof =
+ match su with
+ | Struct -> sizeof_struct env m
+ | Union -> sizeof_union env m }
+
+(* Type of a function definition *)
+
+let fundef_typ fd =
+ TFun(fd.fd_ret, Some fd.fd_params, fd.fd_vararg, [])
+
+(* Signedness of integer kinds *)
+
+let is_signed_ikind = function
+ | IBool -> false
+ | IChar -> !config.char_signed
+ | ISChar -> true
+ | IUChar -> false
+ | IInt -> true
+ | IUInt -> false
+ | IShort -> true
+ | IUShort -> false
+ | ILong -> true
+ | IULong -> false
+ | ILongLong -> true
+ | IULongLong -> false
+
+(* Conversion to unsigned ikind *)
+
+let unsigned_ikind_of = function
+ | IBool -> IBool
+ | IChar | ISChar | IUChar -> IUChar
+ | IInt | IUInt -> IUInt
+ | IShort | IUShort -> IUShort
+ | ILong | IULong -> IULong
+ | ILongLong | IULongLong -> IULongLong
+
+(* Some classification functions over types *)
+
+let is_void_type env t =
+ match unroll env t with
+ | TVoid _ -> true
+ | _ -> false
+
+let is_integer_type env t =
+ match unroll env t with
+ | TInt(_, _) -> true
+ | _ -> false
+
+let is_arith_type env t =
+ match unroll env t with
+ | TInt(_, _) -> true
+ | TFloat(_, _) -> true
+ | _ -> false
+
+let is_pointer_type env t =
+ match unroll env t with
+ | TPtr _ -> true
+ | _ -> false
+
+let is_scalar_type env t =
+ match unroll env t with
+ | TInt(_, _) -> true
+ | TFloat(_, _) -> true
+ | TPtr _ -> true
+ | TArray _ -> true (* assume implicit decay *)
+ | TFun _ -> true (* assume implicit decay *)
+ | _ -> false
+
+let is_composite_type env t =
+ match unroll env t with
+ | TStruct _ | TUnion _ -> true
+ | _ -> false
+
+let is_function_type env t =
+ match unroll env t with
+ | TFun _ -> true
+ | _ -> false
+
+(* Ranking of integer kinds *)
+
+let integer_rank = function
+ | IBool -> 1
+ | IChar | ISChar | IUChar -> 2
+ | IShort | IUShort -> 3
+ | IInt | IUInt -> 4
+ | ILong | IULong -> 5
+ | ILongLong | IULongLong -> 6
+
+(* Ranking of float kinds *)
+
+let float_rank = function
+ | FFloat -> 1
+ | FDouble -> 2
+ | FLongDouble -> 3
+
+(* Array and function types "decay" to pointer types in many cases *)
+
+let pointer_decay env t =
+ match unroll env t with
+ | TArray(ty, _, _) -> TPtr(ty, [])
+ | TFun _ as ty -> TPtr(ty, [])
+ | t -> t
+
+(* The usual unary conversions (H&S 6.3.3) *)
+
+let unary_conversion env t =
+ match unroll env t with
+ (* Promotion of small integer types *)
+ | TInt(kind, attr) ->
+ begin match kind with
+ | IBool | IChar | ISChar | IUChar | IShort | IUShort ->
+ TInt(IInt, attr)
+ | IInt | IUInt | ILong | IULong | ILongLong | IULongLong ->
+ TInt(kind, attr)
+ end
+ (* Arrays and functions decay automatically to pointers *)
+ | TArray(ty, _, _) -> TPtr(ty, [])
+ | TFun _ as ty -> TPtr(ty, [])
+ (* Other types are not changed *)
+ | t -> t
+
+(* The usual binary conversions (H&S 6.3.4).
+ Applies only to arithmetic types.
+ Return the type to which both sides are to be converted. *)
+
+let binary_conversion env t1 t2 =
+ let t1 = unary_conversion env t1 in
+ let t2 = unary_conversion env t2 in
+ match unroll env t1, unroll env t2 with
+ | TFloat(FLongDouble, _), (TInt _ | TFloat _) -> t1
+ | (TInt _ | TFloat _), TFloat(FLongDouble, _) -> t2
+ | TFloat(FDouble, _), (TInt _ | TFloat _) -> t1
+ | (TInt _ | TFloat _), TFloat(FDouble, _) -> t2
+ | TFloat(FFloat, _), (TInt _ | TFloat _) -> t1
+ | (TInt _), TFloat(FFloat, _) -> t2
+ | TInt(k1, _), TInt(k2, _) ->
+ if k1 = k2 then t1 else begin
+ match is_signed_ikind k1, is_signed_ikind k2 with
+ | true, true | false, false ->
+ (* take the bigger of the two types *)
+ if integer_rank k1 >= integer_rank k2 then t1 else t2
+ | false, true ->
+ (* if rank (unsigned type) >= rank (signed type),
+ take the unsigned type *)
+ if integer_rank k1 >= integer_rank k2 then t1
+ (* if rank (unsigned type) < rank (signed type)
+ and all values of the unsigned type can be represented
+ in the signed type, take the signed type *)
+ else if sizeof_ikind k2 > sizeof_ikind k1 then t2
+ (* if rank (unsigned type) < rank (signed type)
+ and some values of the unsigned type cannot be represented
+ in the signed type,
+ take the unsigned type corresponding to the signed type *)
+ else TInt(unsigned_ikind_of k2, [])
+ | true, false ->
+ if integer_rank k2 >= integer_rank k1 then t2
+ else if sizeof_ikind k1 > sizeof_ikind k2 then t1
+ else TInt(unsigned_ikind_of k1, [])
+ end
+ | _, _ -> assert false
+
+(* Conversion on function arguments (with protoypes) *)
+
+let argument_conversion env t =
+ (* Arrays and functions degrade automatically to pointers *)
+ (* Other types are not changed *)
+ match unroll env t with
+ | TArray(ty, _, _) -> TPtr(ty, [])
+ | TFun _ as ty -> TPtr(ty, [])
+ | _ -> t (* preserve typedefs *)
+
+(* Conversion on function arguments (old-style unprototyped, or vararg *)
+(* H&S 6.3.5 *)
+
+let default_argument_conversion env t =
+ match unary_conversion env t with
+ | TFloat(FFloat, attr) -> TFloat(FDouble, attr)
+ | t' -> t'
+
+(** Is the type Tptr(ty, a) appropriate for pointer arithmetic? *)
+
+let pointer_arithmetic_ok env ty =
+ match unroll env ty with
+ | TVoid _ | TFun _ -> false
+ | _ -> not (incomplete_type env ty)
+
+(** Special types *)
+
+let find_matching_unsigned_ikind sz =
+ if sz = !config.sizeof_int then IUInt
+ else if sz = !config.sizeof_long then IULong
+ else if sz = !config.sizeof_longlong then IULongLong
+ else assert false
+
+let find_matching_signed_ikind sz =
+ if sz = !config.sizeof_int then IInt
+ else if sz = !config.sizeof_long then ILong
+ else if sz = !config.sizeof_longlong then ILongLong
+ else assert false
+
+let wchar_ikind = find_matching_unsigned_ikind !config.sizeof_wchar
+let size_t_ikind = find_matching_unsigned_ikind !config.sizeof_size_t
+let ptr_t_ikind = find_matching_unsigned_ikind !config.sizeof_ptr
+let ptrdiff_t_ikind = find_matching_signed_ikind !config.sizeof_ptrdiff_t
+let enum_ikind = IInt
+
+(** The type of a constant *)
+
+let type_of_constant = function
+ | CInt(_, ik, _) -> TInt(ik, [])
+ | CFloat(_, fk, _) -> TFloat(fk, [])
+ | CStr _ -> TPtr(TInt(IChar, []), []) (* XXX or array? const? *)
+ | CWStr _ -> TPtr(TInt(wchar_ikind, []), []) (* XXX or array? const? *)
+ | CEnum(_, _) -> TInt(IInt, [])
+
+(* Check that a C expression is a lvalue *)
+
+let rec is_lvalue env e =
+ (* Type must not be array or function *)
+ match unroll env e.etyp with
+ | TFun _ | TArray _ -> false
+ | _ ->
+ match e.edesc with
+ | EVar id -> true
+ | EUnop((Oderef | Oarrow _), _) -> true
+ | EUnop(Odot _, e') -> is_lvalue env e'
+ | EBinop(Oindex, _, _, _) -> true
+ | _ -> false
+
+(* Check that a C expression is the literal "0", which can be used
+ as a pointer. *)
+
+let is_literal_0 e =
+ match e.edesc with
+ | EConst(CInt(0L, _, _)) -> true
+ | _ -> false
+
+(* Check that an assignment is allowed *)
+
+let valid_assignment env from tto =
+ match pointer_decay env from.etyp, pointer_decay env tto with
+ | (TInt _ | TFloat _), (TInt _ | TFloat _) -> true
+ | TInt _, TPtr _ -> is_literal_0 from
+ | TPtr(ty, _), TPtr(ty', _) ->
+ incl_attributes (attributes_of_type env ty) (attributes_of_type env ty')
+ && (is_void_type env ty || is_void_type env ty'
+ || compatible_types env
+ (erase_attributes_type env ty)
+ (erase_attributes_type env ty'))
+ | TStruct(s, _), TStruct(s', _) -> s = s'
+ | TUnion(s, _), TUnion(s', _) -> s = s'
+ | _, _ -> false
+
+(* Check that a cast is allowed *)
+
+let valid_cast env tfrom tto =
+ compatible_types ~noattrs:true env tfrom tto ||
+ begin match unroll env tfrom, unroll env tto with
+ | _, TVoid _ -> true
+ (* from any int-or-pointer (with array and functions decaying to pointers)
+ to any int-or-pointer *)
+ | (TInt _ | TPtr _ | TArray _ | TFun _), (TInt _ | TPtr _) -> true
+ (* between int and float types *)
+ | (TInt _ | TFloat _), (TInt _ | TFloat _) -> true
+ | _, _ -> false
+ end
+
+(* Construct an integer constant *)
+
+let intconst v ik =
+ { edesc = EConst(CInt(v, ik, "")); etyp = TInt(ik, []) }
+
+(* Construct a float constant *)
+
+let floatconst v fk =
+ { edesc = EConst(CFloat(v, fk, "")); etyp = TFloat(fk, []) }
+
+(* Construct the literal "0" with void * type *)
+
+let nullconst =
+ { edesc = EConst(CInt(0L, ptr_t_ikind, "0")); etyp = TPtr(TVoid [], []) }
+
+(* Construct a sequence *)
+
+let sseq loc s1 s2 =
+ match s1.sdesc, s2.sdesc with
+ | Sskip, _ -> s2
+ | _, Sskip -> s1
+ | _, Sblock sl -> { sdesc = Sblock(s1 :: sl); sloc = loc }
+ | _, _ -> { sdesc = Sseq(s1, s2); sloc = loc }
+
+(* Construct an assignment statement *)
+
+let sassign loc lv rv =
+ { sdesc = Sdo {edesc = EBinop(Oassign, lv, rv, lv.etyp); etyp = lv.etyp};
+ sloc = loc }
+
+(* Empty location *)
+
+let no_loc = ("", -1)
+
+(* Dummy skip statement *)
+
+let sskip = { sdesc = Sskip; sloc = no_loc }
+
+(* Print a location *)
+
+let printloc oc (filename, lineno) =
+ if filename <> "" then Printf.fprintf oc "%s:%d: " filename lineno
+
+(* Format a location *)
+
+let formatloc pp (filename, lineno) =
+ if filename <> "" then Format.fprintf pp "%s:%d: " filename lineno
+
+
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Useful functions to manipulate C abstract syntax *)
+
+open C
+
+(* Sets and maps over identifiers *)
+module IdentSet : Set.S with type elt = ident
+module IdentMap : Map.S with type key = ident
+
+(* Typedef handling *)
+val unroll : Env.t -> typ -> typ
+ (* Expand typedefs at head of type. Returned type is not [TNamed]. *)
+
+(* Attributes *)
+
+val add_attributes : attributes -> attributes -> attributes
+ (* Union of two sets of attributes *)
+val remove_attributes : attributes -> attributes -> attributes
+ (* Difference [attr1 \ attr2] between two sets of attributes *)
+val incl_attributes : attributes -> attributes -> bool
+ (* Check that first set of attributes is a subset of second set. *)
+val attributes_of_type : Env.t -> typ -> attributes
+ (* Return the attributes of the given type, expanding typedefs if needed. *)
+val add_attributes_type : attributes -> typ -> typ
+ (* Add the given set of attributes to those of the given type. *)
+val remove_attributes_type : Env.t -> attributes -> typ -> typ
+ (* Remove the given set of attributes to those of the given type. *)
+val erase_attributes_type : Env.t -> typ -> typ
+ (* Erase the attributes of the given type. *)
+
+(* Type compatibility *)
+val compatible_types : ?noattrs: bool -> Env.t -> typ -> typ -> bool
+ (* Check that the two given types are compatible.
+ If [noattrs], ignore attributes (recursively). *)
+val combine_types : ?noattrs: bool -> Env.t -> typ -> typ -> typ option
+ (* Like [compatible_types], but if the two types are compatible,
+ return the most precise type compatible with both. *)
+
+(* Size and alignment *)
+
+val sizeof : Env.t -> typ -> int option
+ (* Return the size alignment of the given type, in bytes.
+ Machine-dependent. [None] is returned if the type is incomplete. *)
+val alignof : Env.t -> typ -> int option
+ (* Return the natural alignment of the given type, in bytes.
+ Machine-dependent. [None] is returned if the type is incomplete. *)
+val sizeof_ikind: ikind -> int
+ (* Return the size of the given integer kind. *)
+val incomplete_type : Env.t -> typ -> bool
+ (* Return true if the given type is incomplete, e.g.
+ declared but not defined struct or union, or array type without a size. *)
+
+(* Computing composite_info records *)
+
+val composite_info_decl: Env.t -> struct_or_union -> Env.composite_info
+val composite_info_def: Env.t -> struct_or_union -> field list -> Env.composite_info
+
+(* Type classification functions *)
+
+val is_void_type : Env.t -> typ -> bool
+ (* Is type [void]? *)
+val is_integer_type : Env.t -> typ -> bool
+ (* Is type integer? *)
+val is_arith_type : Env.t -> typ -> bool
+ (* Is type integer or float? *)
+val is_pointer_type : Env.t -> typ -> bool
+ (* Is type a pointer type? *)
+val is_scalar_type : Env.t -> typ -> bool
+ (* Is type integer, float or pointer? *)
+val is_composite_type : Env.t -> typ -> bool
+ (* Is type a struct or union? *)
+val is_function_type : Env.t -> typ -> bool
+ (* Is type a function type? (not pointer to function) *)
+val pointer_arithmetic_ok : Env.t -> typ -> bool
+ (* Is the type [*ty] appropriate for pointer arithmetic?
+ [ty] must not be void, nor a function type, nor an incomplete type. *)
+val is_signed_ikind : ikind -> bool
+ (* Return true if the given integer kind is a signed type. *)
+val unsigned_ikind_of : ikind -> ikind
+ (* Return the unsigned integer kind corresponding to the given
+ integer kind. *)
+val integer_rank : ikind -> int
+ (* Order integer kinds from smaller to bigger *)
+val float_rank : fkind -> int
+ (* Order float kinds from smaller to bigger *)
+
+(* Usual conversions over types *)
+
+val pointer_decay : Env.t -> typ -> typ
+ (* Transform (decay) array and function types to pointer types. *)
+val unary_conversion : Env.t -> typ -> typ
+ (* The usual unary conversions:
+ small integer types are promoted to [int]
+ array and function types decay *)
+val binary_conversion : Env.t -> typ -> typ -> typ
+ (* The usual binary conversions. Applies only to arithmetic types.
+ Return the arithmetic type to which both operands of the binop
+ are converted. *)
+val argument_conversion : Env.t -> typ -> typ
+ (* Conversion applied to the argument of a prototyped function.
+ Equivalent to [pointer_decay]. *)
+val default_argument_conversion : Env.t -> typ -> typ
+ (* Conversion applied to the argument of a nonprototyped or variadic
+ function. Like unary conversion, plus [float] becomes [double]. *)
+
+(* Special types *)
+val enum_ikind : ikind
+ (* Integer kind for enum values. Always [IInt]. *)
+val wchar_ikind : ikind
+ (* Integer kind for wchar_t type. Unsigned. *)
+val size_t_ikind : ikind
+ (* Integer kind for size_t type. Unsigned. *)
+val ptr_t_ikind : ikind
+ (* Integer kind for ptr_t type. Smallest unsigned kind large enough
+ to contain a pointer without information loss. *)
+val ptrdiff_t_ikind : ikind
+ (* Integer kind for ptrdiff_t type. Smallest signed kind large enough
+ to contain the difference between two pointers. *)
+
+(* Helpers for type-checking *)
+
+val type_of_constant : constant -> typ
+ (* Return the type of the given constant. *)
+val is_literal_0 : exp -> bool
+ (* Is the given expression the integer literal "0"? *)
+val is_lvalue : Env.t -> exp -> bool
+ (* Is the given expression a l-value? *)
+val valid_assignment : Env.t -> exp -> typ -> bool
+ (* Check that an assignment of the given expression to a l-value of
+ the given type is allowed. *)
+val valid_cast : Env.t -> typ -> typ -> bool
+ (* Check that a cast from the first type to the second is allowed. *)
+val fundef_typ: fundef -> typ
+ (* Return the function type for the given function definition. *)
+
+(* Constructors *)
+
+val intconst : int64 -> ikind -> exp
+ (* Build expression for given integer constant. *)
+val floatconst : float -> fkind -> exp
+ (* Build expression for given float constant. *)
+val nullconst : exp
+ (* Expression for [(void * ) 0] *)
+val sskip: stmt
+ (* The [skip] statement. No location. *)
+val sseq : location -> stmt -> stmt -> stmt
+ (* Return the statement [s1; s2], optimizing the cases
+ where [s1] or [s2] is [skip], or [s2] is a block. *)
+val sassign : location -> exp -> exp -> stmt
+ (* Return the statement [exp1 = exp2;] *)
+
+(* Locations *)
+
+val no_loc: location
+ (* Denotes an unknown location. *)
+val printloc: out_channel -> location -> unit
+ (* Printer for locations (for Printf) *)
+val formatloc: Format.formatter -> location -> unit
+ (* Printer for locations (for Format) *)
+
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Elaboration from Cabs parse tree to C simplified, typed syntax tree *)
+
+open Format
+open Errors
+open Machine
+open Cabs
+open Cabshelper
+open C
+open Cutil
+open Env
+
+(** * Utility functions *)
+
+(* Error reporting *)
+
+let fatal_error loc fmt =
+ Errors.fatal_error ("%a: Error:@ " ^^ fmt) format_cabsloc loc
+
+let error loc fmt =
+ Errors.error ("%a: Error:@ " ^^ fmt) format_cabsloc loc
+
+let warning loc fmt =
+ Errors.warning ("%a: Warning:@ " ^^ fmt) format_cabsloc loc
+
+(* Error reporting for Env functions *)
+
+let wrap fn loc env arg =
+ try fn env arg
+ with Env.Error msg -> fatal_error loc "%s" (Env.error_message msg)
+
+(* Translation of locations *)
+
+let elab_loc l = (l.filename, l.lineno)
+
+(* Buffering of the result (a list of topdecl *)
+
+let top_declarations = ref ([] : globdecl list)
+
+let emit_elab loc td =
+ top_declarations := { gdesc = td; gloc = loc } :: !top_declarations
+
+let reset() = top_declarations := []
+
+let elaborated_program () =
+ let p = !top_declarations in
+ top_declarations := [];
+ (* Reverse it and eliminate unreferenced declarations *)
+ Cleanup.program p
+
+(* Location stuff *)
+
+let loc_of_name (_, _, _, loc) = loc
+
+let loc_of_namelist = function [] -> cabslu | name :: _ -> loc_of_name name
+
+let loc_of_init_name_list =
+ function [] -> cabslu | (name, init) :: _ -> loc_of_name name
+
+(* Monadic map for functions env -> 'a -> 'b * env *)
+
+let rec mmap f env = function
+ | [] -> ([], env)
+ | hd :: tl ->
+ let (hd', env1) = f env hd in
+ let (tl', env2) = mmap f env1 tl in
+ (hd' :: tl', env2)
+
+(* To detect redefinitions within the same scope *)
+
+let redef fn env arg =
+ try
+ let (id, info) = fn env arg in
+ if Env.in_current_scope env id then Some(id, info) else None
+ with Env.Error _ ->
+ None
+
+(* Forward declarations *)
+
+let elab_expr_f : (cabsloc -> Env.t -> Cabs.expression -> C.exp) ref
+ = ref (fun _ _ _ -> assert false)
+
+let elab_block_f : (cabsloc -> C.typ -> Env.t -> Cabs.block -> C.stmt) ref
+ = ref (fun _ _ _ _ -> assert false)
+
+\f
+(** * Elaboration of constants *)
+
+let has_suffix s suff =
+ let ls = String.length s and lsuff = String.length suff in
+ ls >= lsuff && String.sub s (ls - lsuff) lsuff = suff
+
+let chop_last s n =
+ assert (String.length s >= n);
+ String.sub s 0 (String.length s - n)
+
+let has_prefix s pref =
+ let ls = String.length s and lpref = String.length pref in
+ ls >= lpref && String.sub s 0 lpref = pref
+
+let chop_first s n =
+ assert (String.length s >= n);
+ String.sub s n (String.length s - n)
+
+exception Overflow
+exception Bad_digit
+
+let parse_int base s =
+ let max_val = (* (2^64-1) / base, unsigned *)
+ match base with
+ | 8 -> 2305843009213693951L
+ | 10 -> 1844674407370955161L
+ | 16 -> 1152921504606846975L
+ | _ -> assert false in
+ let v = ref 0L in
+ for i = 0 to String.length s - 1 do
+ if !v > max_val then raise Overflow;
+ v := Int64.mul !v (Int64.of_int base);
+ let c = s.[i] in
+ let digit =
+ if c >= '0' && c <= '9' then Char.code c - 48
+ else if c >= 'A' && c <= 'F' then Char.code c - 55
+ else raise Bad_digit in
+ if digit >= base then raise Bad_digit;
+ v := Int64.add !v (Int64.of_int digit)
+ done;
+ !v
+
+let integer_representable v ik =
+ let bitsize = sizeof_ikind ik * 8
+ and signed = is_signed_ikind ik in
+ if bitsize >= 64 then
+ (not signed) || (v >= 0L && v <= 0x7FFF_FFFF_FFFF_FFFFL)
+ else if not signed then
+ v >= 0L && v < Int64.shift_left 1L bitsize
+ else
+ v >= 0L && v < Int64.shift_left 1L (bitsize - 1)
+
+let elab_int_constant loc s0 =
+ let s = String.uppercase s0 in
+ (* Determine possible types and chop type suffix *)
+ let (s, dec_kinds, hex_kinds) =
+ if has_suffix s "ULL" || has_suffix s "LLU" then
+ (chop_last s 3, [IULongLong], [IULongLong])
+ else if has_suffix s "LL" then
+ (chop_last s 2, [ILongLong], [ILongLong; IULongLong])
+ else if has_suffix s "UL" || has_suffix s "LU" then
+ (chop_last s 2, [IULong; IULongLong], [IULong; IULongLong])
+ else if has_suffix s "L" then
+ (chop_last s 1, [ILong; ILongLong],
+ [ILong; IULong; ILongLong; IULongLong])
+ else if has_suffix s "U" then
+ (chop_last s 1, [IUInt; IULong; IULongLong],
+ [IUInt; IULong; IULongLong])
+ else
+ (s, [IInt; ILong; IULong; ILongLong],
+ [IInt; IUInt; ILong; IULong; ILongLong; IULongLong])
+ in
+ (* Determine base *)
+ let (s, base) =
+ if has_prefix s "0X" then
+ (chop_first s 2, 16)
+ else if has_prefix s "0" then
+ (chop_first s 1, 8)
+ else
+ (s, 10)
+ in
+ (* Parse digits *)
+ let v =
+ try parse_int base s
+ with
+ | Overflow ->
+ error loc "integer literal '%s' is too large" s0;
+ 0L
+ | Bad_digit ->
+ error loc "bad digit in integer literal '%s'" s0;
+ 0L
+ in
+ (* Find smallest allowable type that fits *)
+ let ty =
+ try List.find (fun ty -> integer_representable v ty)
+ (if base = 10 then dec_kinds else hex_kinds)
+ with Not_found ->
+ error loc "integer literal '%s' cannot be represented" s0;
+ IInt
+ in
+ (v, ty)
+
+let elab_float_constant loc s0 =
+ let s = String.uppercase s0 in
+ (* Determine type and chop suffix *)
+ let (s, ty) =
+ if has_suffix s "L" then
+ (chop_last s 1, FLongDouble)
+ else if has_suffix s "F" then
+ (chop_last s 1, FFloat)
+ else
+ (s, FDouble) in
+ (* Convert to Caml float - XXX loss of precision for long double *)
+ let v =
+ try float_of_string s
+ with Failure _ -> error loc "bad float literal '%s'" s0; 0.0 in
+ (v, ty)
+
+let elab_char_constant loc sz cl =
+ let nbits = 8 * sz in
+ (* Treat multi-char constants as a number in base 2^nbits *)
+ let max_val = Int64.shift_left 1L (64 - nbits) in
+ let v =
+ List.fold_left
+ (fun acc d ->
+ if acc >= max_val then begin
+ error loc "character literal overflows";
+ end;
+ Int64.add (Int64.shift_left acc nbits) d)
+ 0L cl in
+ let ty =
+ if v < 256L then IInt
+ else if v < Int64.shift_left 1L (8 * sizeof_ikind IULong) then IULong
+ else IULongLong in
+ (v, ty)
+
+let elab_constant loc = function
+ | CONST_INT s ->
+ let (v, ik) = elab_int_constant loc s in
+ CInt(v, ik, s)
+ | CONST_FLOAT s ->
+ let (v, fk) = elab_float_constant loc s in
+ CFloat(v, fk, s)
+ | CONST_CHAR cl ->
+ let (v, ik) = elab_char_constant loc 1 cl in
+ CInt(v, ik, "")
+ | CONST_WCHAR cl ->
+ let (v, ik) = elab_char_constant loc !config.sizeof_wchar cl in
+ CInt(v, ik, "")
+ | CONST_STRING s -> CStr s
+ | CONST_WSTRING s -> CWStr s
+
+\f
+(** * Elaboration of type expressions, type specifiers, name declarations *)
+
+(* Elaboration of attributes *)
+
+let elab_attribute loc = function
+ | ("const", []) -> Some AConst
+ | ("restrict", []) -> Some ARestrict
+ | ("volatile", []) -> Some AVolatile
+ | (name, args) ->
+ (* warning loc "ignoring '%s' attribute" name; *)
+ None
+
+let rec elab_attributes loc = function
+ | [] -> []
+ | a1 :: al ->
+ match elab_attribute loc a1 with
+ | None -> elab_attributes loc al
+ | Some a -> add_attributes [a] (elab_attributes loc al)
+
+(* Auxiliary for typespec elaboration *)
+
+let typespec_rank = function (* Don't change this *)
+ | Cabs.Tvoid -> 0
+ | Cabs.Tsigned -> 1
+ | Cabs.Tunsigned -> 2
+ | Cabs.Tchar -> 3
+ | Cabs.Tshort -> 4
+ | Cabs.Tlong -> 5
+ | Cabs.Tint -> 6
+ | Cabs.Tint64 -> 7
+ | Cabs.Tfloat -> 8
+ | Cabs.Tdouble -> 9
+ | Cabs.T_Bool -> 10
+ | _ -> 11 (* There should be at most one of the others *)
+
+let typespec_order t1 t2 = compare (typespec_rank t1) (typespec_rank t2)
+
+(* Elaboration of a type specifier. Returns 4-tuple:
+ (storage class, "inline" flag, elaborated type, new env)
+ Optional argument "only" is true if this is a standalone
+ struct or union declaration, without variable names.
+*)
+
+let rec elab_specifier ?(only = false) loc env specifier =
+ (* We first divide the parts of the specifier as follows:
+ - a storage class
+ - a set of attributes (const, volatile, restrict)
+ - a list of type specifiers *)
+ let sto = ref Storage_default
+ and inline = ref false
+ and attr = ref []
+ and tyspecs = ref [] in
+
+ let do_specifier = function
+ | SpecTypedef -> ()
+ | SpecCV cv ->
+ let a =
+ match cv with
+ | CV_CONST -> AConst
+ | CV_VOLATILE -> AVolatile
+ | CV_RESTRICT -> ARestrict in
+ attr := add_attributes [a] !attr
+ | SpecAttr a ->
+ attr := add_attributes (elab_attributes loc [a]) !attr
+ | SpecStorage st ->
+ if !sto <> Storage_default then
+ error loc "multiple storage specifiers";
+ begin match st with
+ | NO_STORAGE -> ()
+ | AUTO -> ()
+ | STATIC -> sto := Storage_static
+ | EXTERN -> sto := Storage_extern
+ | REGISTER -> sto := Storage_register
+ end
+ | SpecInline -> inline := true
+ | SpecType tys -> tyspecs := tys :: !tyspecs in
+
+ List.iter do_specifier specifier;
+
+ let simple ty = (!sto, !inline, add_attributes_type !attr ty, env) in
+
+ (* Now interpret the list of type specifiers. Much of this code
+ is stolen from CIL. *)
+ match List.stable_sort typespec_order (List.rev !tyspecs) with
+ | [Cabs.Tvoid] -> simple (TVoid [])
+
+ | [Cabs.T_Bool] -> simple (TInt(IBool, []))
+ | [Cabs.Tchar] -> simple (TInt(IChar, []))
+ | [Cabs.Tsigned; Cabs.Tchar] -> simple (TInt(ISChar, []))
+ | [Cabs.Tunsigned; Cabs.Tchar] -> simple (TInt(IUChar, []))
+
+ | [Cabs.Tshort] -> simple (TInt(IShort, []))
+ | [Cabs.Tsigned; Cabs.Tshort] -> simple (TInt(IShort, []))
+ | [Cabs.Tshort; Cabs.Tint] -> simple (TInt(IShort, []))
+ | [Cabs.Tsigned; Cabs.Tshort; Cabs.Tint] -> simple (TInt(IShort, []))
+
+ | [Cabs.Tunsigned; Cabs.Tshort] -> simple (TInt(IUShort, []))
+ | [Cabs.Tunsigned; Cabs.Tshort; Cabs.Tint] -> simple (TInt(IUShort, []))
+
+ | [] -> simple (TInt(IInt, []))
+ | [Cabs.Tint] -> simple (TInt(IInt, []))
+ | [Cabs.Tsigned] -> simple (TInt(IInt, []))
+ | [Cabs.Tsigned; Cabs.Tint] -> simple (TInt(IInt, []))
+
+ | [Cabs.Tunsigned] -> simple (TInt(IUInt, []))
+ | [Cabs.Tunsigned; Cabs.Tint] -> simple (TInt(IUInt, []))
+
+ | [Cabs.Tlong] -> simple (TInt(ILong, []))
+ | [Cabs.Tsigned; Cabs.Tlong] -> simple (TInt(ILong, []))
+ | [Cabs.Tlong; Cabs.Tint] -> simple (TInt(ILong, []))
+ | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tint] -> simple (TInt(ILong, []))
+
+ | [Cabs.Tunsigned; Cabs.Tlong] -> simple (TInt(IULong, []))
+ | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tint] -> simple (TInt(IULong, []))
+
+ | [Cabs.Tlong; Cabs.Tlong] -> simple (TInt(ILongLong, []))
+ | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tlong] -> simple (TInt(ILongLong, []))
+ | [Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> simple (TInt(ILongLong, []))
+ | [Cabs.Tsigned; Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> simple (TInt(ILongLong, []))
+
+ | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tlong] -> simple (TInt(IULongLong, []))
+ | [Cabs.Tunsigned; Cabs.Tlong; Cabs.Tlong; Cabs.Tint] -> simple (TInt(IULongLong, []))
+
+ (* int64 is a MSVC extension *)
+ | [Cabs.Tint64] -> simple (TInt(ILongLong, []))
+ | [Cabs.Tsigned; Cabs.Tint64] -> simple (TInt(ILongLong, []))
+ | [Cabs.Tunsigned; Cabs.Tint64] -> simple (TInt(IULongLong, []))
+
+ | [Cabs.Tfloat] -> simple (TFloat(FFloat, []))
+ | [Cabs.Tdouble] -> simple (TFloat(FDouble, []))
+
+ | [Cabs.Tlong; Cabs.Tdouble] -> simple (TFloat(FLongDouble, []))
+
+ (* Now the other type specifiers *)
+
+ | [Cabs.Tnamed id] ->
+ let (id', info) = wrap Env.lookup_typedef loc env id in
+ simple (TNamed(id', []))
+
+ | [Cabs.Tstruct(id, optmembers, a)] ->
+ let (id', env') =
+ elab_struct_or_union only Struct loc id optmembers env in
+ let attr' = add_attributes !attr (elab_attributes loc a) in
+ (!sto, !inline, TStruct(id', attr'), env')
+
+ | [Cabs.Tunion(id, optmembers, a)] ->
+ let (id', env') =
+ elab_struct_or_union only Union loc id optmembers env in
+ let attr' = add_attributes !attr (elab_attributes loc a) in
+ (!sto, !inline, TUnion(id', attr'), env')
+
+ | [Cabs.Tenum(id, optmembers, a)] ->
+ let env' =
+ elab_enum loc id optmembers env in
+ let attr' = add_attributes !attr (elab_attributes loc a) in
+ (!sto, !inline, TInt(enum_ikind, attr'), env')
+
+ | [Cabs.TtypeofE _] ->
+ fatal_error loc "GCC __typeof__ not supported"
+ | [Cabs.TtypeofT _] ->
+ fatal_error loc "GCC __typeof__ not supported"
+
+ (* Specifier doesn't make sense *)
+ | _ ->
+ fatal_error loc "illegal combination of type specifiers"
+
+(* Elaboration of a type declarator. *)
+
+and elab_type_declarator loc env ty = function
+ | Cabs.JUSTBASE ->
+ (ty, env)
+ | Cabs.PARENTYPE(attr1, d, attr2) ->
+ (* XXX ignoring the distinction between attrs after and before *)
+ let a = elab_attributes loc (attr1 @ attr2) in
+ elab_type_declarator loc env (add_attributes_type a ty) d
+ | Cabs.ARRAY(d, attr, sz) ->
+ let a = elab_attributes loc attr in
+ let sz' =
+ match sz with
+ | Cabs.NOTHING ->
+ None
+ | _ ->
+ match Ceval.integer_expr env (!elab_expr_f loc env sz) with
+ | Some n ->
+ if n < 0L then error loc "array size is negative";
+ Some n
+ | None ->
+ error loc "array size is not a compile-time constant";
+ Some 1L in (* produces better error messages later *)
+ elab_type_declarator loc env (TArray(ty, sz', a)) d
+ | Cabs.PTR(attr, d) ->
+ let a = elab_attributes loc attr in
+ elab_type_declarator loc env (TPtr(ty, a)) d
+ | Cabs.PROTO(d, params, vararg) ->
+ begin match unroll env ty with
+ | TArray _ | TFun _ ->
+ error loc "illegal function return type@ %a" Cprint.typ ty
+ | _ -> ()
+ end;
+ let params' = elab_parameters env params in
+ elab_type_declarator loc env (TFun(ty, params', vararg, [])) d
+
+(* Elaboration of parameters in a prototype *)
+
+and elab_parameters env params =
+ match params with
+ | [] -> (* old-style K&R prototype *)
+ None
+ | _ ->
+ (* Prototype introduces a new scope *)
+ let (vars, _) = mmap elab_parameter (Env.new_scope env) params in
+ (* Catch special case f(void) *)
+ match vars with
+ | [ ( {name=""}, TVoid _) ] -> Some []
+ | _ -> Some vars
+
+(* Elaboration of a function parameter *)
+
+and elab_parameter env (spec, name) =
+ let (id, sto, inl, ty, env1) = elab_name env spec name in
+ if sto <> Storage_default && sto <> Storage_register then
+ error (loc_of_name name)
+ "'extern' or 'static' storage not supported for function parameter";
+ (* replace array and function types by pointer types *)
+ let ty1 = argument_conversion env1 ty in
+ let (id', env2) = Env.enter_ident env1 id sto ty1 in
+ ( (id', ty1) , env2 )
+
+(* Elaboration of a (specifier, Cabs "name") pair *)
+
+and elab_name env spec (id, decl, attr, loc) =
+ let (sto, inl, bty, env') = elab_specifier loc env spec in
+ let (ty, env'') = elab_type_declarator loc env' bty decl in
+ let a = elab_attributes loc attr in
+ (id, sto, inl, add_attributes_type a ty, env'')
+
+(* Elaboration of a name group *)
+
+and elab_name_group env (spec, namelist) =
+ let (sto, inl, bty, env') =
+ elab_specifier (loc_of_namelist namelist) env spec in
+ let elab_one_name env (id, decl, attr, loc) =
+ let (ty, env1) =
+ elab_type_declarator loc env bty decl in
+ let a = elab_attributes loc attr in
+ ((id, sto, add_attributes_type a ty), env1) in
+ mmap elab_one_name env' namelist
+
+(* Elaboration of an init-name group *)
+
+and elab_init_name_group env (spec, namelist) =
+ let (sto, inl, bty, env') =
+ elab_specifier (loc_of_init_name_list namelist) env spec in
+ let elab_one_name env ((id, decl, attr, loc), init) =
+ let (ty, env1) =
+ elab_type_declarator loc env bty decl in
+ let a = elab_attributes loc attr in
+ ((id, sto, add_attributes_type a ty, init), env1) in
+ mmap elab_one_name env' namelist
+
+(* Elaboration of a field group *)
+
+and elab_field_group env (spec, fieldlist) =
+ let (names, env') =
+ elab_name_group env (spec, List.map fst fieldlist) in
+
+ let elab_bitfield ((_, _, _, loc), optbitsize) (id, sto, ty) =
+ if sto <> Storage_default then
+ error loc "member '%s' has non-default storage" id;
+ let optbitsize' =
+ match optbitsize with
+ | None -> None
+ | Some sz ->
+ let ik =
+ match unroll env' ty with
+ | TInt(ik, _) -> ik
+ | _ -> ILongLong (* trigger next error message *) in
+ if integer_rank ik > integer_rank IInt then
+ error loc
+ "the type of a bit field must be an integer type \
+ no bigger than 'int'";
+ match Ceval.integer_expr env' (!elab_expr_f loc env sz) with
+ | Some n ->
+ if n < 0L then begin
+ error loc "bit size of member (%Ld) is negative" n;
+ None
+ end else
+ if n > Int64.of_int(sizeof_ikind ik * 8) then begin
+ error loc "bit size of member (%Ld) is too large" n;
+ None
+ end else
+ Some(Int64.to_int n)
+ | None ->
+ error loc "bit size of member is not a compile-time constant";
+ None in
+ { fld_name = id; fld_typ = ty; fld_bitfield = optbitsize' }
+ in
+ (List.map2 elab_bitfield fieldlist names, env')
+
+(* Elaboration of a struct or union *)
+
+and elab_struct_or_union_info kind loc env members =
+ let (m, env') = mmap elab_field_group env members in
+ let m = List.flatten m in
+ (* Check for incomplete types *)
+ let rec check_incomplete = function
+ | [] -> ()
+ | [ { fld_typ = TArray(ty_elt, None, _) } ] when kind = Struct -> ()
+ (* C99: ty[] allowed as last field of a struct *)
+ | fld :: rem ->
+ if incomplete_type env' fld.fld_typ then
+ error loc "member '%s' has incomplete type" fld.fld_name;
+ check_incomplete rem in
+ check_incomplete m;
+ (composite_info_def env' kind m, env')
+
+(* Elaboration of a struct or union *)
+
+and elab_struct_or_union only kind loc tag optmembers env =
+ let optbinding =
+ if tag = "" then None else Env.lookup_composite env tag in
+ match optbinding, optmembers with
+ | Some(tag', ci), None
+ when (not only) || Env.in_current_scope env tag' ->
+ (* Reference to an already declared struct or union.
+ Special case: if this is an "only" declaration (without variable names)
+ and the composite was bound in another scope,
+ create a new incomplete composite instead via the case
+ "_, None" below. *)
+ (tag', env)
+ | Some(tag', ({ci_sizeof = None} as ci)), Some members
+ when Env.in_current_scope env tag' ->
+ if ci.ci_kind <> kind then
+ error loc "struct/union mismatch on tag '%s'" tag;
+ (* finishing the definition of an incomplete struct or union *)
+ let (ci', env') = elab_struct_or_union_info kind loc env members in
+ (* Emit a global definition for it *)
+ emit_elab (elab_loc loc)
+ (Gcompositedef(kind, tag', ci'.ci_members));
+ (* Replace infos but keep same ident *)
+ (tag', Env.add_composite env' tag' ci')
+ | Some(tag', {ci_sizeof = Some _}), Some _
+ when Env.in_current_scope env tag' ->
+ error loc "redefinition of struct or union '%s'" tag;
+ (tag', env)
+ | _, None ->
+ (* declaration of an incomplete struct or union *)
+ if tag = "" then
+ error loc "anonymous, incomplete struct or union";
+ let ci = composite_info_decl env kind in
+ (* enter it with a new name *)
+ let (tag', env') = Env.enter_composite env tag ci in
+ (* emit it *)
+ emit_elab (elab_loc loc)
+ (Gcompositedecl(kind, tag'));
+ (tag', env')
+ | _, Some members ->
+ (* definition of a complete struct or union *)
+ let ci1 = composite_info_decl env kind in
+ (* enter it, incomplete, with a new name *)
+ let (tag', env') = Env.enter_composite env tag ci1 in
+ (* emit a declaration so that inner structs and unions can refer to it *)
+ emit_elab (elab_loc loc)
+ (Gcompositedecl(kind, tag'));
+ (* elaborate the members *)
+ let (ci2, env'') = elab_struct_or_union_info kind loc env' members in
+ (* emit a definition *)
+ emit_elab (elab_loc loc)
+ (Gcompositedef(kind, tag', ci2.ci_members));
+ (* Replace infos but keep same ident *)
+ (tag', Env.add_composite env'' tag' ci2)
+
+(* Elaboration of an enum item *)
+
+and elab_enum_item env (s, exp, loc) nextval =
+ let (v, exp') =
+ match exp with
+ | NOTHING ->
+ (nextval, None)
+ | _ ->
+ let exp' = !elab_expr_f loc env exp in
+ match Ceval.integer_expr env exp' with
+ | Some n -> (n, Some exp')
+ | None ->
+ error loc
+ "value of enumerator '%s' is not a compile-time constant" s;
+ (nextval, Some exp') in
+ if redef Env.lookup_ident env s <> None then
+ error loc "redefinition of enumerator '%s'" s;
+ let (id, env') = Env.enter_enum_item env s v in
+ ((id, exp'), Int64.succ v, env')
+
+(* Elaboration of an enumeration declaration *)
+
+and elab_enum loc tag optmembers env =
+ match optmembers with
+ | None -> env
+ | Some members ->
+ let rec elab_members env nextval = function
+ | [] -> ([], env)
+ | hd :: tl ->
+ let (dcl1, nextval1, env1) = elab_enum_item env hd nextval in
+ let (dcl2, env2) = elab_members env1 nextval1 tl in
+ (dcl1 :: dcl2, env2) in
+ let (dcls, env') = elab_members env 0L members in
+ let tag' = Env.fresh_ident tag in
+ emit_elab (elab_loc loc) (Genumdef(tag', dcls));
+ env'
+
+(* Elaboration of a naked type, e.g. in a cast *)
+
+let elab_type loc env spec decl =
+ let (sto, inl, bty, env') = elab_specifier loc env spec in
+ let (ty, env'') = elab_type_declarator loc env' bty decl in
+ if sto <> Storage_default || inl then
+ error loc "'extern', 'static', 'register' and 'inline' are meaningless in cast";
+ ty
+
+\f
+(* Elaboration of expressions *)
+
+let elab_expr loc env a =
+
+ let err fmt = error loc fmt in (* non-fatal error *)
+ let error fmt = fatal_error loc fmt in
+ let warning fmt = warning loc fmt in
+
+ let rec elab = function
+
+ | NOTHING ->
+ error "empty expression"
+
+(* 7.3 Primary expressions *)
+
+ | VARIABLE s ->
+ begin match wrap Env.lookup_ident loc env s with
+ | (id, II_ident(sto, ty)) ->
+ { edesc = EVar id; etyp = ty }
+ | (id, II_enum v) ->
+ { edesc = EConst(CEnum(id, v)); etyp = TInt(enum_ikind, []) }
+ end
+
+ | CONSTANT cst ->
+ let cst' = elab_constant loc cst in
+ { edesc = EConst cst'; etyp = type_of_constant cst' }
+
+ | PAREN e ->
+ elab e
+
+(* 7.4 Postfix expressions *)
+
+ | INDEX(a1, a2) -> (* e1[e2] *)
+ let b1 = elab a1 in let b2 = elab a2 in
+ let tres =
+ match (unroll env b1.etyp, unroll env b2.etyp) with
+ | (TPtr(t, _) | TArray(t, _, _)), TInt _ -> t
+ | TInt _, (TPtr(t, _) | TArray(t, _, _)) -> t
+ | t1, t2 -> error "incorrect types for array subscripting" in
+ { edesc = EBinop(Oindex, b1, b2, TPtr(tres, [])); etyp = tres }
+
+ | MEMBEROF(a1, fieldname) ->
+ let b1 = elab a1 in
+ let (fld, attrs) =
+ match unroll env b1.etyp with
+ | TStruct(id, attrs) ->
+ (wrap Env.find_struct_member loc env (id, fieldname), attrs)
+ | TUnion(id, attrs) ->
+ (wrap Env.find_union_member loc env (id, fieldname), attrs)
+ | _ ->
+ error "left-hand side of '.' is not a struct or union" in
+ (* A field of a const/volatile struct or union is itself const/volatile *)
+ { edesc = EUnop(Odot fieldname, b1);
+ etyp = add_attributes_type attrs fld.fld_typ }
+
+ | MEMBEROFPTR(a1, fieldname) ->
+ let b1 = elab a1 in
+ let (fld, attrs) =
+ match unroll env b1.etyp with
+ | TPtr(t, _) ->
+ begin match unroll env t with
+ | TStruct(id, attrs) ->
+ (wrap Env.find_struct_member loc env (id, fieldname), attrs)
+ | TUnion(id, attrs) ->
+ (wrap Env.find_union_member loc env (id, fieldname), attrs)
+ | _ ->
+ error "left-hand side of '->' is not a pointer to a struct or union"
+ end
+ | _ ->
+ error "left-hand side of '->' is not a pointer " in
+ { edesc = EUnop(Oarrow fieldname, b1);
+ etyp = add_attributes_type attrs fld.fld_typ }
+
+(* Hack to treat vararg.h functions the GCC way. Helps with testing.
+ va_start(ap,n)
+ (preprocessing) --> __builtin_va_start(ap, arg)
+ (elaboration) --> __builtin_va_start(ap, &arg)
+ va_arg(ap, ty)
+ (preprocessing) --> __builtin_va_arg(ap, ty)
+ (parsing) --> __builtin_va_arg(ap, sizeof(ty))
+*)
+ | CALL((VARIABLE "__builtin_va_start" as a1), [a2; a3]) ->
+ let b1 = elab a1 and b2 = elab a2 and b3 = elab a3 in
+ { edesc = ECall(b1, [b2; {edesc = EUnop(Oaddrof, b3);
+ etyp = TPtr(b3.etyp, [])}]);
+ etyp = TVoid [] }
+ | CALL((VARIABLE "__builtin_va_arg" as a1),
+ [a2; (TYPE_SIZEOF _) as a3]) ->
+ let b1 = elab a1 and b2 = elab a2 and b3 = elab a3 in
+ let ty = match b3.edesc with ESizeof ty -> ty | _ -> assert false in
+ { edesc = ECall(b1, [b2; b3]); etyp = ty }
+
+ | CALL(a1, al) ->
+ let b1 =
+ (* Catch the old-style usage of calling a function without
+ having declared it *)
+ match a1 with
+ | VARIABLE n when not (Env.ident_is_bound env n) ->
+ let ty = TFun(TInt(IInt, []), None, false, []) in
+ (* Emit an extern declaration for it *)
+ let id = Env.fresh_ident n in
+ emit_elab (elab_loc loc) (Gdecl(Storage_extern, id, ty, None));
+ { edesc = EVar id; etyp = ty }
+ | _ -> elab a1 in
+ let bl = List.map elab al in
+ (* Extract type information *)
+ let (res, args, vararg) =
+ match unroll env b1.etyp with
+ | TFun(res, args, vararg, a) -> (res, args, vararg)
+ | TPtr(ty, a) ->
+ begin match unroll env ty with
+ | TFun(res, args, vararg, a) -> (res, args, vararg)
+ | _ -> error "the function part of a call does not have a function type"
+ end
+ | _ -> error "the function part of a call does not have a function type"
+ in
+ (* Type-check the arguments against the prototype *)
+ let bl' =
+ match args with
+ | None -> bl
+ | Some proto -> elab_arguments 1 bl proto vararg in
+ { edesc = ECall(b1, bl'); etyp = res }
+
+ | UNARY(POSINCR, a1) ->
+ elab_pre_post_incr_decr Opostincr "postfix '++'" a1
+ | UNARY(POSDECR, a1) ->
+ elab_pre_post_incr_decr Opostdecr "postfix '--'" a1
+
+(* 7.5 Unary expressions *)
+
+ | CAST ((spec, dcl), SINGLE_INIT a1) ->
+ let ty = elab_type loc env spec dcl in
+ let b1 = elab a1 in
+ if not (valid_cast env b1.etyp ty) then
+ err "illegal cast from %a@ to %a" Cprint.typ b1.etyp Cprint.typ ty;
+ { edesc = ECast(ty, b1); etyp = ty }
+
+ | CAST ((spec, dcl), _) ->
+ error "cast of initializer expression is not supported"
+
+ | EXPR_SIZEOF(CONSTANT(CONST_STRING s)) ->
+ let cst = CInt(Int64.of_int (String.length s), size_t_ikind, "") in
+ { edesc = EConst cst; etyp = type_of_constant cst }
+
+ | EXPR_SIZEOF a1 ->
+ let b1 = elab a1 in
+ if sizeof env b1.etyp = None then
+ err "incomplete type %a" Cprint.typ b1.etyp;
+ { edesc = ESizeof b1.etyp; etyp = TInt(size_t_ikind, []) }
+
+ | TYPE_SIZEOF (spec, dcl) ->
+ let ty = elab_type loc env spec dcl in
+ if sizeof env ty = None then
+ err "incomplete type %a" Cprint.typ ty;
+ { edesc = ESizeof ty; etyp = TInt(size_t_ikind, []) }
+
+ | UNARY(PLUS, a1) ->
+ let b1 = elab a1 in
+ if not (is_arith_type env b1.etyp) then
+ error "argument of unary '+' is not an arithmetic type";
+ { edesc = EUnop(Oplus, b1); etyp = unary_conversion env b1.etyp }
+
+ | UNARY(MINUS, a1) ->
+ let b1 = elab a1 in
+ if not (is_arith_type env b1.etyp) then
+ error "argument of unary '-' is not an arithmetic type";
+ { edesc = EUnop(Ominus, b1); etyp = unary_conversion env b1.etyp }
+
+ | UNARY(BNOT, a1) ->
+ let b1 = elab a1 in
+ if not (is_integer_type env b1.etyp) then
+ error "argument of '~' is not an integer type";
+ { edesc = EUnop(Onot, b1); etyp = unary_conversion env b1.etyp }
+
+ | UNARY(NOT, a1) ->
+ let b1 = elab a1 in
+ if not (is_scalar_type env b1.etyp) then
+ error "argument of '!' is not a scalar type";
+ { edesc = EUnop(Olognot, b1); etyp = TInt(IInt, []) }
+
+ | UNARY(ADDROF, a1) ->
+ let b1 = elab a1 in
+ begin match unroll env b1.etyp with
+ | TArray _ | TFun _ -> ()
+ | _ ->
+ if not (is_lvalue env b1) then err "argument of '&' is not a l-value"
+ end;
+ { edesc = EUnop(Oaddrof, b1); etyp = TPtr(b1.etyp, []) }
+
+ | UNARY(MEMOF, a1) ->
+ let b1 = elab a1 in
+ begin match unroll env b1.etyp with
+ (* '*' applied to a function type has no effect *)
+ | TFun _ -> b1
+ | TPtr(ty, _) | TArray(ty, _, _) ->
+ { edesc = EUnop(Oderef, b1); etyp = ty }
+ | _ ->
+ error "argument of unary '*' is not a pointer"
+ end
+
+ | UNARY(PREINCR, a1) ->
+ elab_pre_post_incr_decr Opreincr "prefix '++'" a1
+ | UNARY(PREDECR, a1) ->
+ elab_pre_post_incr_decr Opredecr "prefix '--'" a1
+
+(* 7.6 Binary operator expressions *)
+
+ | BINARY(MUL, a1, a2) ->
+ elab_binary_arithmetic "*" Omul a1 a2
+
+ | BINARY(DIV, a1, a2) ->
+ elab_binary_arithmetic "/" Odiv a1 a2
+
+ | BINARY(MOD, a1, a2) ->
+ elab_binary_integer "/" Omod a1 a2
+
+ | BINARY(ADD, a1, a2) ->
+ let b1 = elab a1 in
+ let b2 = elab a2 in
+ let tyres =
+ if is_arith_type env b1.etyp && is_arith_type env b2.etyp then
+ binary_conversion env b1.etyp b2.etyp
+ else begin
+ let (ty, attr) =
+ match unroll env b1.etyp, unroll env b2.etyp with
+ | (TPtr(ty, a) | TArray(ty, _, a)), TInt _ -> (ty, a)
+ | TInt _, (TPtr(ty, a) | TArray(ty, _, a)) -> (ty, a)
+ | _, _ -> error "type error in binary '+'" in
+ if not (pointer_arithmetic_ok env ty) then
+ err "illegal pointer arithmetic in binary '+'";
+ TPtr(ty, attr)
+ end in
+ { edesc = EBinop(Oadd, b1, b2, tyres); etyp = tyres }
+
+ | BINARY(SUB, a1, a2) ->
+ let b1 = elab a1 in
+ let b2 = elab a2 in
+ let (tyop, tyres) =
+ if is_arith_type env b1.etyp && is_arith_type env b2.etyp then begin
+ let tyres = binary_conversion env b1.etyp b2.etyp in
+ (tyres, tyres)
+ end else begin
+ match unroll env b1.etyp, unroll env b2.etyp with
+ | (TPtr(ty, a) | TArray(ty, _, a)), TInt _ ->
+ if not (pointer_arithmetic_ok env ty) then
+ err "illegal pointer arithmetic in binary '-'";
+ (TPtr(ty, a), TPtr(ty, a))
+ | TInt _, (TPtr(ty, a) | TArray(ty, _, a)) ->
+ if not (pointer_arithmetic_ok env ty) then
+ err "illegal pointer arithmetic in binary '-'";
+ (TPtr(ty, a), TPtr(ty, a))
+ | (TPtr(ty1, a1) | TArray(ty1, _, a1)),
+ (TPtr(ty2, a2) | TArray(ty2, _, a2)) ->
+ if not (compatible_types ~noattrs:true env ty1 ty2) then
+ err "mismatch between pointer types in binary '-'";
+ if not (pointer_arithmetic_ok env ty1) then
+ err "illegal pointer arithmetic in binary '-'";
+ (TPtr(ty1, []), TInt(ptrdiff_t_ikind, []))
+ | _, _ -> error "type error in binary '-'"
+ end in
+ { edesc = EBinop(Osub, b1, b2, tyop); etyp = tyres }
+
+ | BINARY(SHL, a1, a2) ->
+ elab_shift "<<" Oshl a1 a2
+
+ | BINARY(SHR, a1, a2) ->
+ elab_shift ">>" Oshr a1 a2
+
+ | BINARY(EQ, a1, a2) ->
+ elab_comparison Oeq a1 a2
+ | BINARY(NE, a1, a2) ->
+ elab_comparison One a1 a2
+ | BINARY(LT, a1, a2) ->
+ elab_comparison Olt a1 a2
+ | BINARY(GT, a1, a2) ->
+ elab_comparison Ogt a1 a2
+ | BINARY(LE, a1, a2) ->
+ elab_comparison Ole a1 a2
+ | BINARY(GE, a1, a2) ->
+ elab_comparison Oge a1 a2
+
+ | BINARY(BAND, a1, a2) ->
+ elab_binary_integer "&" Oand a1 a2
+ | BINARY(BOR, a1, a2) ->
+ elab_binary_integer "|" Oor a1 a2
+ | BINARY(XOR, a1, a2) ->
+ elab_binary_integer "^" Oxor a1 a2
+
+(* 7.7 Logical operator expressions *)
+
+ | BINARY(AND, a1, a2) ->
+ elab_logical_operator "&&" Ologand a1 a2
+ | BINARY(OR, a1, a2) ->
+ elab_logical_operator "||" Ologor a1 a2
+
+(* 7.8 Conditional expressions *)
+ | QUESTION(a1, a2, a3) ->
+ let b1 = elab a1 in
+ let b2 = elab a2 in
+ let b3 = elab a3 in
+ if not (is_scalar_type env b1.etyp) then
+ err ("the first argument of '? :' is not a scalar type");
+ begin match pointer_decay env b2.etyp, pointer_decay env b3.etyp with
+ | (TInt _ | TFloat _), (TInt _ | TFloat _) ->
+ { edesc = EConditional(b1, b2, b3);
+ etyp = binary_conversion env b2.etyp b3.etyp }
+ | TPtr(ty1, a1), TPtr(ty2, a2) ->
+ let tyres =
+ if is_void_type env ty1 || is_void_type env ty2 then
+ TPtr(TVoid [], add_attributes a1 a2)
+ else
+ match combine_types ~noattrs:true env
+ (TPtr(ty1, a1)) (TPtr(ty2, a2)) with
+ | None ->
+ error "the second and third arguments of '? :' \
+ have incompatible pointer types"
+ | Some ty -> ty
+ in
+ { edesc = EConditional(b1, b2, b3); etyp = tyres }
+ | TPtr(ty1, a1), TInt _ when is_literal_0 b3 ->
+ { edesc = EConditional(b1, b2, nullconst); etyp = TPtr(ty1, a1) }
+ | TInt _, TPtr(ty2, a2) when is_literal_0 b2 ->
+ { edesc = EConditional(b1, nullconst, b3); etyp = TPtr(ty2, a2) }
+ | ty1, ty2 ->
+ match combine_types env ty1 ty2 with
+ | None ->
+ error ("the second and third arguments of '? :' have incompatible types")
+ | Some tyres ->
+ { edesc = EConditional(b1, b2, b3); etyp = tyres }
+ end
+
+(* 7.9 Assignment expressions *)
+
+ | BINARY(ASSIGN, a1, a2) ->
+ let b1 = elab a1 in
+ let b2 = elab a2 in
+ if not (is_lvalue env b1) then
+ err "left-hand side of assignment is not a l-value";
+ if List.mem AConst (attributes_of_type env b1.etyp) then
+ err "left-hand side of assignment has 'const' type";
+ if not (valid_assignment env b2 b1.etyp) then begin
+ if valid_cast env b2.etyp b1.etyp then
+ warning "assigning a value of type@ %a@ to a lvalue of type@ %a"
+ Cprint.typ b2.etyp Cprint.typ b1.etyp
+ else
+ err "assigning a value of type@ %a@ to a lvalue of type@ %a"
+ Cprint.typ b2.etyp Cprint.typ b1.etyp;
+ end;
+ { edesc = EBinop(Oassign, b1, b2, b1.etyp); etyp = b1.etyp }
+
+ | BINARY((ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN
+ | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN
+ as op), a1, a2) ->
+ let (sop, top) =
+ match op with
+ | ADD_ASSIGN -> (ADD, Oadd_assign)
+ | SUB_ASSIGN -> (SUB, Osub_assign)
+ | MUL_ASSIGN -> (MUL, Omul_assign)
+ | DIV_ASSIGN -> (DIV, Odiv_assign)
+ | MOD_ASSIGN -> (MOD, Omod_assign)
+ | BAND_ASSIGN -> (BAND, Oand_assign)
+ | BOR_ASSIGN -> (BOR, Oor_assign)
+ | XOR_ASSIGN -> (XOR, Oxor_assign)
+ | SHL_ASSIGN -> (SHL, Oshl_assign)
+ | SHR_ASSIGN -> (SHR, Oshr_assign)
+ | _ -> assert false in
+ begin match elab (BINARY(sop, a1, a2)) with
+ | { edesc = EBinop(_, b1, b2, _); etyp = ty } as b ->
+ if not (is_lvalue env b1) then
+ err ("left-hand side of assignment is not a l-value");
+ if List.mem AConst (attributes_of_type env b1.etyp) then
+ err "left-hand side of assignment has 'const' type";
+ if not (valid_assignment env b b1.etyp) then begin
+ if valid_cast env ty b1.etyp then
+ warning "assigning a value of type@ %a@ to a lvalue of type@ %a"
+ Cprint.typ ty Cprint.typ b1.etyp
+ else
+ err "assigning a value of type@ %a@ to a lvalue of type@ %a"
+ Cprint.typ ty Cprint.typ b1.etyp;
+ end;
+ { edesc = EBinop(top, b1, b2, ty); etyp = b1.etyp }
+ | _ -> assert false
+ end
+
+(* 7.10 Sequential expressions *)
+
+ | COMMA [] ->
+ error "empty sequential expression"
+ | COMMA (a1 :: al) -> (* watch for left associativity *)
+ let rec elab_comma accu = function
+ | [] -> accu
+ | a :: l ->
+ let b = elab a in
+ elab_comma { edesc = EBinop(Ocomma, accu, b, b.etyp); etyp = b.etyp } l
+ in elab_comma (elab a1) al
+
+(* Extensions that we do not handle *)
+
+ | LABELADDR _ ->
+ error "GCC's &&label construct is not supported"
+ | GNU_BODY _ ->
+ error "GCC's statements within expressions are not supported"
+ | EXPR_ALIGNOF _ | TYPE_ALIGNOF _ ->
+ error "GCC's __alignof__ construct is not supported"
+
+(*
+ | EXPR_ALIGNOF a1 ->
+ warning "nonstandard `alignof' expression, turned into a constant";
+ let b1 = elab a1 in
+ begin match alignof env b1.etyp with
+ | None -> error "incomplete type %a" Cprint.typ b1.etyp
+ | Some al -> intconst (Int64.of_int al) size_t_ikind
+ end
+ | TYPE_ALIGNOF (spec, dcl) ->
+ warning "nonstandard `alignof' expression, turned into a constant";
+ let ty = elab_type loc env spec dcl in
+ begin match alignof env ty with
+ | None -> error "incomplete type %a" Cprint.typ ty
+ | Some al -> intconst (Int64.of_int al) size_t_ikind
+ end
+*)
+
+(* Elaboration of pre- or post- increment/decrement *)
+ and elab_pre_post_incr_decr op msg a1 =
+ let b1 = elab a1 in
+ if not (is_lvalue env b1) then
+ err "the argument of %s is not a l-value" msg;
+ if not (is_scalar_type env b1.etyp) then
+ err "the argument of %s must be an arithmetic or pointer type" msg;
+ { edesc = EUnop(op, b1); etyp = b1.etyp }
+
+(* Elaboration of binary operators over integers *)
+ and elab_binary_integer msg op a1 a2 =
+ let b1 = elab a1 in
+ if not (is_integer_type env b1.etyp) then
+ error "the first argument of '%s' is not an integer type" msg;
+ let b2 = elab a2 in
+ if not (is_integer_type env b2.etyp) then
+ error "the second argument of '%s' is not an integer type" msg;
+ let tyres = binary_conversion env b1.etyp b2.etyp in
+ { edesc = EBinop(op, b1, b2, tyres); etyp = tyres }
+
+(* Elaboration of binary operators over arithmetic types *)
+ and elab_binary_arithmetic msg op a1 a2 =
+ let b1 = elab a1 in
+ if not (is_arith_type env b1.etyp) then
+ error "the first argument of '%s' is not an arithmetic type" msg;
+ let b2 = elab a2 in
+ if not (is_arith_type env b2.etyp) then
+ error "the second argument of '%s' is not an arithmetic type" msg;
+ let tyres = binary_conversion env b1.etyp b2.etyp in
+ { edesc = EBinop(op, b1, b2, tyres); etyp = tyres }
+
+(* Elaboration of shift operators *)
+ and elab_shift msg op a1 a2 =
+ let b1 = elab a1 in
+ if not (is_integer_type env b1.etyp) then
+ error "the first argument of '%s' is not an integer type" msg;
+ let b2 = elab a2 in
+ if not (is_integer_type env b2.etyp) then
+ error "the second argument of '%s' is not an integer type" msg;
+ let tyres = unary_conversion env b1.etyp in
+ { edesc = EBinop(op, b1, b2, tyres); etyp = tyres }
+
+(* Elaboration of comparisons *)
+ and elab_comparison op a1 a2 =
+ let b1 = elab a1 in
+ let b2 = elab a2 in
+ let resdesc =
+ match pointer_decay env b1.etyp, pointer_decay env b2.etyp with
+ | (TInt _ | TFloat _), (TInt _ | TFloat _) ->
+ EBinop(op, b1, b2, binary_conversion env b1.etyp b2.etyp)
+ | TInt _, TPtr(ty, _) when is_literal_0 b1 ->
+ EBinop(op, nullconst, b2, TPtr(ty, []))
+ | TPtr(ty, _), TInt _ when is_literal_0 b2 ->
+ EBinop(op, b1, nullconst, TPtr(ty, []))
+ | TPtr(ty1, _), TPtr(ty2, _)
+ when is_void_type env ty1 ->
+ EBinop(op, b1, b2, TPtr(ty2, []))
+ | TPtr(ty1, _), TPtr(ty2, _)
+ when is_void_type env ty2 ->
+ EBinop(op, b1, b2, TPtr(ty1, []))
+ | TPtr(ty1, _), TPtr(ty2, _) ->
+ if not (compatible_types ~noattrs:true env ty1 ty2) then
+ warning "comparison between incompatible pointer types";
+ EBinop(op, b1, b2, TPtr(ty1, []))
+ | TPtr _, TInt _
+ | TInt _, TPtr _ ->
+ warning "comparison between integer and pointer";
+ EBinop(op, b1, b2, TPtr(TVoid [], []))
+ | ty1, ty2 ->
+ error "illegal comparison between types@ %a@ and %a"
+ Cprint.typ b1.etyp Cprint.typ b2.etyp in
+ { edesc = resdesc; etyp = TInt(IInt, []) }
+
+(* Elaboration of && and || *)
+ and elab_logical_operator msg op a1 a2 =
+ let b1 = elab a1 in
+ if not (is_scalar_type env b1.etyp) then
+ err "the first argument of '%s' is not a scalar type" msg;
+ let b2 = elab a2 in
+ if not (is_scalar_type env b2.etyp) then
+ err "the second argument of '%s' is not a scalar type" msg;
+ { edesc = EBinop(op, b1, b2, TInt(IInt, [])); etyp = TInt(IInt, []) }
+
+(* Type-checking of function arguments *)
+ and elab_arguments argno args params vararg =
+ match args, params with
+ | [], [] -> []
+ | [], _::_ -> err "not enough arguments in function call"; []
+ | _::_, [] ->
+ if vararg
+ then args
+ else (err "too many arguments in function call"; args)
+ | arg1 :: argl, (_, ty_p) :: paraml ->
+ let ty_a = argument_conversion env arg1.etyp in
+ if not (valid_assignment env {arg1 with etyp = ty_a} ty_p) then begin
+ if valid_cast env ty_a ty_p then
+ warning
+ "argument #%d of function call has type@ %a@ \
+ instead of the expected type@ %a"
+ argno Cprint.typ ty_a Cprint.typ ty_p
+ else
+ err
+ "argument #%d of function call has type@ %a@ \
+ instead of the expected type@ %a"
+ argno Cprint.typ ty_a Cprint.typ ty_p
+ end;
+ arg1 :: elab_arguments (argno + 1) argl paraml vararg
+
+ in elab a
+
+(* Filling in forward declaration *)
+let _ = elab_expr_f := elab_expr
+
+let elab_opt_expr loc env = function
+ | NOTHING -> None
+ | a -> Some (elab_expr loc env a)
+
+let elab_for_expr loc env = function
+ | NOTHING -> { sdesc = Sskip; sloc = elab_loc loc }
+ | a -> { sdesc = Sdo (elab_expr loc env a); sloc = elab_loc loc }
+
+\f
+(* Elaboration of initializers *)
+
+(* Initializers are first elaborated to the following type: *)
+
+let project_init loc il =
+ List.map
+ (fun (what, i) ->
+ if what <> NEXT_INIT then
+ error loc "C99 initializers are not supported";
+ i)
+ il
+
+let below_optsize n opt_sz =
+ match opt_sz with None -> true | Some sz -> n < sz
+
+let init_char_array_string opt_size s =
+ let init = ref []
+ and len = ref 0L in
+ let enter x =
+ if below_optsize !len opt_size then begin
+ init := Init_single (intconst x IChar) :: !init;
+ len := Int64.succ !len
+ end in
+ for i = 0 to String.length s - 1 do
+ enter (Int64.of_int (Char.code s.[i]))
+ done;
+ enter 0L;
+ Init_array (List.rev !init)
+
+let init_int_array_wstring opt_size s =
+ let init = ref []
+ and len = ref 0L in
+ let enter x =
+ if below_optsize !len opt_size then begin
+ init := Init_single (intconst x IInt) :: !init;
+ len := Int64.succ !len
+ end in
+ List.iter enter s;
+ enter 0L;
+ Init_array (List.rev !init)
+
+let check_init_type loc env a ty =
+ if valid_assignment env a ty then ()
+ else if valid_cast env a.etyp ty then
+ warning loc
+ "initializer has type@ %a@ instead of the expected type @ %a"
+ Cprint.typ a.etyp Cprint.typ ty
+ else
+ error loc
+ "initializer has type@ %a@ instead of the expected type @ %a"
+ Cprint.typ a.etyp Cprint.typ ty
+
+(* Build an initializer for type [ty], consuming initialization items
+ from the list [ile]. Return a pair (initializer, items not consumed). *)
+
+let rec elab_init loc env ty ile =
+ match unroll env ty with
+ | TArray(ty_elt, opt_sz, _) ->
+ let rec elab_init_array n accu rem =
+ match opt_sz, rem with
+ | Some sz, _ when n >= sz ->
+ (Init_array(List.rev accu), rem)
+ | None, [] ->
+ (Init_array(List.rev accu), rem)
+ | _, _ ->
+ let (i, rem') = elab_init loc env ty_elt rem in
+ elab_init_array (Int64.succ n) (i :: accu) rem' in
+ begin match ile with
+ (* char array = "string literal" *)
+ | (SINGLE_INIT (CONSTANT (CONST_STRING s))
+ | COMPOUND_INIT [_, SINGLE_INIT(CONSTANT (CONST_STRING s))]) :: ile1
+ when (match unroll env ty_elt with
+ | TInt((IChar|IUChar|ISChar), _) -> true
+ | _ -> false) ->
+ (init_char_array_string opt_sz s, ile1)
+ (* wchar array = L"wide string literal" *)
+ | (SINGLE_INIT (CONSTANT (CONST_WSTRING s))
+ | COMPOUND_INIT [_, SINGLE_INIT(CONSTANT (CONST_WSTRING s))]) :: ile1
+ when (match unroll env ty_elt with
+ | TInt _ -> true
+ | _ -> false) ->
+ (init_int_array_wstring opt_sz s, ile1)
+ (* array = { elt, ..., elt } *)
+ | COMPOUND_INIT ile1 :: ile2 ->
+ let (ie, rem) = elab_init_array 0L [] (project_init loc ile1) in
+ if rem <> [] then
+ warning loc "excess elements at end of array initializer";
+ (ie, ile2)
+ (* array = elt, ..., elt (within a bigger compound initializer) *)
+ | _ ->
+ elab_init_array 0L [] ile
+ end
+ | TStruct(id, _) ->
+ let ci = wrap Env.find_struct loc env id in
+ let rec elab_init_fields fld accu rem =
+ match fld with
+ | [] ->
+ (Init_struct(id, List.rev accu), rem)
+ | fld1 :: fld' ->
+ let (i, rem') = elab_init loc env fld1.fld_typ rem in
+ elab_init_fields fld' ((fld1, i) :: accu) rem' in
+ begin match ile with
+ (* struct = { elt, ..., elt } *)
+ | COMPOUND_INIT ile1 :: ile2 ->
+ let (ie, rem) =
+ elab_init_fields ci.ci_members [] (project_init loc ile1) in
+ if rem <> [] then
+ warning loc "excess elements at end of struct initializer";
+ (ie, ile2)
+ (* struct = elt, ..., elt (within a bigger compound initializer) *)
+ | _ ->
+ elab_init_fields ci.ci_members [] ile
+ end
+ | TUnion(id, _) ->
+ let ci = wrap Env.find_union loc env id in
+ let fld1 =
+ match ci.ci_members with [] -> assert false | hd :: tl -> hd in
+ begin match ile with
+ (* union = { elt } *)
+ | COMPOUND_INIT ile1 :: ile2 ->
+ let (i, rem) =
+ elab_init loc env fld1.fld_typ (project_init loc ile1) in
+ if rem <> [] then
+ warning loc "excess elements at end of union initializer";
+ (Init_union(id, fld1, i), ile2)
+ (* union = elt (within a bigger compound initializer) *)
+ | _ ->
+ let (i, rem) = elab_init loc env fld1.fld_typ ile in
+ (Init_union(id, fld1, i), rem)
+ end
+ | TInt _ | TFloat _ | TPtr _ ->
+ begin match ile with
+ (* scalar = elt *)
+ | SINGLE_INIT a :: ile1 ->
+ let a' = elab_expr loc env a in
+ check_init_type loc env a' ty;
+ (Init_single a', ile1)
+ (* scalar = nothing (within a bigger compound initializer) *)
+ | (NO_INIT :: ile1) | ([] as ile1) ->
+ begin match unroll env ty with
+ | TInt _ -> (Init_single (intconst 0L IInt), ile1)
+ | TFloat _ -> (Init_single (floatconst 0.0 FDouble), ile1)
+ | TPtr _ -> (Init_single nullconst, ile1)
+ | _ -> assert false
+ end
+ | COMPOUND_INIT _ :: ile1 ->
+ fatal_error loc "compound initializer for type@ %a" Cprint.typ ty
+ end
+ | _ ->
+ fatal_error loc "impossible to initialize at type@ %a" Cprint.typ ty
+
+let elab_initial loc env ty ie =
+ match unroll env ty, ie with
+ | _, NO_INIT -> None
+ (* scalar or composite = expr *)
+ | (TInt _ | TFloat _ | TPtr _ | TStruct _ | TUnion _), SINGLE_INIT a ->
+ let a' = elab_expr loc env a in
+ check_init_type loc env a' ty;
+ Some (Init_single a')
+ (* array = expr or
+ array or struct or union = { elt, ..., elt } *)
+ | (TArray _, SINGLE_INIT _)
+ | ((TArray _ | TStruct _ | TUnion _), COMPOUND_INIT _) ->
+ let (i, rem) = elab_init loc env ty [ie] in
+ if rem <> [] then
+ warning loc "excess elements at end of compound initializer";
+ Some i
+ | _, _ ->
+ error loc "ill-formed initializer for type@ %a" Cprint.typ ty;
+ None
+
+(* Complete an array type with the size obtained from the initializer:
+ "int x[] = { 1, 2, 3 }" becomes "int x[3] = ..." *)
+
+let fixup_typ env ty init =
+ match unroll env ty, init with
+ | TArray(ty_elt, None, attr), Init_array il ->
+ TArray(ty_elt, Some(Int64.of_int(List.length il)), attr)
+ | _ -> ty
+
+(* Entry point *)
+
+let elab_initializer loc env ty ie =
+ match elab_initial loc env ty ie with
+ | None ->
+ (ty, None)
+ | Some init ->
+ (fixup_typ env ty init, Some init)
+
+\f
+(* Elaboration of top-level and local definitions *)
+
+let enter_typedef loc env (s, sto, ty) =
+ if sto <> Storage_default then
+ error loc "Non-default storage on 'typedef' definition";
+ if redef Env.lookup_typedef env s <> None then
+ error loc "Redefinition of typedef '%s'" s;
+ let (id, env') =
+ Env.enter_typedef env s ty in
+ emit_elab (elab_loc loc) (Gtypedef(id, ty));
+ env'
+
+let enter_or_refine_ident local loc env s sto ty =
+ match redef Env.lookup_ident env s with
+ | Some(id, II_ident(old_sto, old_ty)) ->
+ let new_ty =
+ if local then begin
+ error loc "redefinition of local variable '%s'" s;
+ ty
+ end else begin
+ match combine_types env old_ty ty with
+ | Some new_ty ->
+ new_ty
+ | None ->
+ warning loc "redefinition of '%s' with incompatible type" s; ty
+ end in
+ let new_sto =
+ if old_sto = Storage_extern then sto else
+ if sto = Storage_extern then old_sto else
+ if old_sto = sto then sto else begin
+ warning loc "redefinition of '%s' with incompatible storage class" s;
+ sto
+ end in
+ (id, Env.add_ident env id new_sto new_ty)
+ | Some(id, II_enum v) ->
+ error loc "illegal redefinition of enumerator '%s'" s;
+ (id, Env.add_ident env id sto ty)
+ | _ ->
+ Env.enter_ident env s sto ty
+
+let rec enter_decdefs local loc env = function
+ | [] ->
+ ([], env)
+ | (s, sto, ty, init) :: rem ->
+ (* Sanity checks on storage class *)
+ begin match sto with
+ | Storage_extern ->
+ if init <> NO_INIT then error loc
+ "'extern' declaration cannot have an initializer"
+ | Storage_register ->
+ if not local then error loc "'register' on global declaration"
+ | _ -> ()
+ end;
+ (* function declarations are always extern *)
+ let sto' =
+ match unroll env ty with TFun _ -> Storage_extern | _ -> sto in
+ (* enter ident in environment with declared type, because
+ initializer can refer to the ident *)
+ let (id, env1) = enter_or_refine_ident local loc env s sto' ty in
+ (* process the initializer *)
+ let (ty', init') = elab_initializer loc env1 ty init in
+ (* update environment with refined type *)
+ let env2 = Env.add_ident env1 id sto' ty' in
+ (* check for incomplete type *)
+ if sto' <> Storage_extern && incomplete_type env ty' then
+ warning loc "'%s' has incomplete type" s;
+ if local && sto <> Storage_extern && sto <> Storage_static then begin
+ (* Local definition *)
+ let (decls, env3) = enter_decdefs local loc env2 rem in
+ ((sto', id, ty', init') :: decls, env3)
+ end else begin
+ (* Global definition *)
+ emit_elab (elab_loc loc) (Gdecl(sto, id, ty', init'));
+ enter_decdefs local loc env2 rem
+ end
+
+let elab_fundef env (spec, name) body loc1 loc2 =
+ let (s, sto, inline, ty, env1) = elab_name env spec name in
+ if sto = Storage_register then
+ error loc1 "a function definition cannot have 'register' storage class";
+ (* Fix up the type. We can have params = None but only for an
+ old-style parameterless function "int f() {...}" *)
+ let ty =
+ match ty with
+ | TFun(ty_ret, None, vararg, attr) -> TFun(ty_ret, Some [], vararg, attr)
+ | _ -> ty in
+ (* Extract info from type *)
+ let (ty_ret, params, vararg) =
+ match ty with
+ | TFun(ty_ret, Some params, vararg, attr) -> (ty_ret, params, vararg)
+ | _ -> fatal_error loc1 "wrong type for function definition" in
+ (* Enter function in the environment, for recursive references *)
+ let (fun_id, env1) = enter_or_refine_ident false loc1 env s sto ty in
+ (* Enter parameters in the environment *)
+ let env2 =
+ List.fold_left (fun e (id, ty) -> Env.add_ident e id Storage_default ty)
+ (Env.new_scope env1) params in
+ (* Elaborate function body *)
+ let body' = !elab_block_f loc2 ty_ret env2 body in
+ (* Build and emit function definition *)
+ let fn =
+ { fd_storage = sto;
+ fd_inline = inline;
+ fd_name = fun_id;
+ fd_ret = ty_ret;
+ fd_params = params;
+ fd_vararg = vararg;
+ fd_locals = [];
+ fd_body = body' } in
+ emit_elab (elab_loc loc1) (Gfundef fn);
+ env1
+
+let rec elab_definition (local: bool) (env: Env.t) (def: Cabs.definition)
+ : decl list * Env.t =
+ match def with
+ (* "int f(int x) { ... }" *)
+ | FUNDEF(spec_name, body, loc1, loc2) ->
+ if local then error loc1 "local definition of a function";
+ let env1 = elab_fundef env spec_name body loc1 loc2 in
+ ([], env1)
+
+ (* "int x = 12, y[10], *z" *)
+ | DECDEF(init_name_group, loc) ->
+ let (dl, env1) = elab_init_name_group env init_name_group in
+ enter_decdefs local loc env1 dl
+
+ (* "typedef int * x, y[10]; " *)
+ | TYPEDEF(namegroup, loc) ->
+ let (dl, env1) = elab_name_group env namegroup in
+ let env2 = List.fold_left (enter_typedef loc) env1 dl in
+ ([], env2)
+
+ (* "struct s { ...};" or "union u;" *)
+ | ONLYTYPEDEF(spec, loc) ->
+ let (sto, inl, ty, env') = elab_specifier ~only:true loc env spec in
+ if sto <> Storage_default || inl then
+ error loc "Non-default storage or 'inline' on 'struct' or 'union' declaration";
+ ([], env')
+
+ (* global asm statement *)
+ | GLOBASM(_, loc) ->
+ error loc "Top-level 'asm' statement is not supported";
+ ([], env)
+
+ (* pragma *)
+ | PRAGMA(s, loc) ->
+ emit_elab (elab_loc loc) (Gpragma s);
+ ([], env)
+
+ (* extern "C" { ... } *)
+ | LINKAGE(_, loc, defs) ->
+ elab_definitions local env defs
+
+and elab_definitions local env = function
+ | [] -> ([], env)
+ | d1 :: dl ->
+ let (decl1, env1) = elab_definition local env d1 in
+ let (decl2, env2) = elab_definitions local env1 dl in
+ (decl1 @ decl2, env2)
+
+\f
+(* Elaboration of statements *)
+
+(* Extract list of Cabs statements from a Cabs block *)
+
+let block_body loc b =
+ if b.blabels <> [] then
+ error loc "GCC's '__label__' declaration is not supported";
+ if b.battrs <> [] then
+ warning loc "ignoring attributes on this block";
+ b.bstmts
+
+(* Elaboration of a block. Return the corresponding C statement. *)
+
+let elab_block loc return_typ env b =
+
+let rec elab_stmt env s =
+
+ match s with
+
+(* 8.2 Expression statements *)
+
+ | COMPUTATION(a, loc) ->
+ { sdesc = Sdo (elab_expr loc env a); sloc = elab_loc loc }
+
+(* 8.3 Labeled statements *)
+
+ | LABEL(lbl, s1, loc) ->
+ { sdesc = Slabeled(Slabel lbl, elab_stmt env s1); sloc = elab_loc loc }
+
+ | CASE(a, s1, loc) ->
+ let a' = elab_expr loc env a in
+ begin match Ceval.integer_expr env a' with
+ | None ->
+ error loc "argument of 'case' must be an integer compile-time constant"
+ | Some n -> ()
+ end;
+ { sdesc = Slabeled(Scase a', elab_stmt env s1); sloc = elab_loc loc }
+
+ | CASERANGE(_, _, _, loc) ->
+ error loc "GCC's 'case' with range of values is not supported";
+ sskip
+
+ | DEFAULT(s1, loc) ->
+ { sdesc = Slabeled(Sdefault, elab_stmt env s1); sloc = elab_loc loc }
+
+(* 8.4 Compound statements *)
+
+ | BLOCK(b, loc) ->
+ elab_blk loc env b
+
+(* 8.5 Conditional statements *)
+
+ | IF(a, s1, s2, loc) ->
+ let a' = elab_expr loc env a in
+ if not (is_scalar_type env a'.etyp) then
+ error loc "the condition of 'if' does not have scalar type";
+ let s1' = elab_stmt env s1 in
+ let s2' = elab_stmt env s2 in
+ { sdesc = Sif(a', s1', s2'); sloc = elab_loc loc }
+
+(* 8.6 Iterative statements *)
+
+ | WHILE(a, s1, loc) ->
+ let a' = elab_expr loc env a in
+ if not (is_scalar_type env a'.etyp) then
+ error loc "the condition of 'while' does not have scalar type";
+ let s1' = elab_stmt env s1 in
+ { sdesc = Swhile(a', s1'); sloc = elab_loc loc }
+
+ | DOWHILE(a, s1, loc) ->
+ let s1' = elab_stmt env s1 in
+ let a' = elab_expr loc env a in
+ if not (is_scalar_type env a'.etyp) then
+ error loc "the condition of 'while' does not have scalar type";
+ { sdesc = Sdowhile(s1', a'); sloc = elab_loc loc }
+
+ | FOR(fc, a2, a3, s1, loc) ->
+ let a1' =
+ match fc with
+ | FC_EXP a1 ->
+ elab_for_expr loc env a1
+ | FC_DECL def ->
+ error loc "C99 declaration within `for' not supported";
+ sskip in
+ let a2' =
+ if a2 = NOTHING
+ then intconst 1L IInt
+ else elab_expr loc env a2 in
+ if not (is_scalar_type env a2'.etyp) then
+ error loc "the condition of 'for' does not have scalar type";
+ let a3' = elab_for_expr loc env a3 in
+ let s1' = elab_stmt env s1 in
+ { sdesc = Sfor(a1', a2', a3', s1'); sloc = elab_loc loc }
+
+(* 8.7 Switch statement *)
+ | SWITCH(a, s1, loc) ->
+ let a' = elab_expr loc env a in
+ if not (is_arith_type env a'.etyp) then
+ error loc "the argument of 'switch' does not have arithmetic type";
+ let s1' = elab_stmt env s1 in
+ { sdesc = Sswitch(a', s1'); sloc = elab_loc loc }
+
+(* 8,8 Break and continue statements *)
+ | BREAK loc ->
+ { sdesc = Sbreak; sloc = elab_loc loc }
+ | CONTINUE loc ->
+ { sdesc = Scontinue; sloc = elab_loc loc }
+
+(* 8.9 Return statements *)
+ | RETURN(a, loc) ->
+ let a' = elab_opt_expr loc env a in
+ begin match (unroll env return_typ, a') with
+ | TVoid _, None -> ()
+ | TVoid _, Some _ ->
+ error loc
+ "'return' with a value in a function of return type 'void'"
+ | _, None ->
+ warning loc
+ "'return' without a value in a function of return type@ %a"
+ Cprint.typ return_typ
+ | _, Some b ->
+ if not (valid_assignment env b return_typ) then begin
+ if valid_cast env b.etyp return_typ then
+ warning loc
+ "return value has type@ %a@ \
+ instead of the expected type@ %a"
+ Cprint.typ b.etyp Cprint.typ return_typ
+ else
+ error loc
+ "return value has type@ %a@ \
+ instead of the expected type@ %a"
+ Cprint.typ b.etyp Cprint.typ return_typ
+ end
+ end;
+ { sdesc = Sreturn a'; sloc = elab_loc loc }
+
+(* 8.10 Goto statements *)
+ | GOTO(lbl, loc) ->
+ { sdesc = Sgoto lbl; sloc = elab_loc loc }
+
+(* 8.11 Null statements *)
+ | NOP loc ->
+ { sdesc = Sskip; sloc = elab_loc loc }
+
+(* Unsupported *)
+ | DEFINITION def ->
+ error (get_definitionloc def) "ill-placed definition";
+ sskip
+ | COMPGOTO(a, loc) ->
+ error loc "GCC's computed 'goto' is not supported";
+ sskip
+ | ASM(_, _, _, loc) ->
+ error loc "'asm' statement is not supported";
+ sskip
+ | TRY_EXCEPT(_, _, _, loc) ->
+ error loc "'try ... except' statement is not supported";
+ sskip
+ | TRY_FINALLY(_, _, loc) ->
+ error loc "'try ... finally' statement is not supported";
+ sskip
+
+and elab_blk loc env b =
+ let b' = elab_blk_body (Env.new_scope env) (block_body loc b) in
+ { sdesc = Sblock b'; sloc = elab_loc loc }
+
+and elab_blk_body env sl =
+ match sl with
+ | [] ->
+ []
+ | DEFINITION def :: sl1 ->
+ let (dcl, env') = elab_definition true env def in
+ let loc = elab_loc (get_definitionloc def) in
+ List.map (fun d -> {sdesc = Sdecl d; sloc = loc}) dcl
+ @ elab_blk_body env' sl1
+ | s :: sl1 ->
+ let s' = elab_stmt env s in
+ s' :: elab_blk_body env sl1
+
+in elab_blk loc env b
+
+(* Filling in forward declaration *)
+let _ = elab_block_f := elab_block
+
+\f
+(** * Entry point *)
+
+let elab_preprocessed_file name ic =
+ let lb = Lexer.init name ic in
+ reset();
+ ignore (elab_definitions false (Builtins.environment())
+ (Parser.file Lexer.initial lb));
+ Lexer.finish();
+ elaborated_program()
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val elab_preprocessed_file : string -> in_channel -> C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Typing environment *)
+
+open C
+
+type error =
+ | Unbound_identifier of string
+ | Unbound_tag of string * string
+ | Tag_mismatch of string * string * string
+ | Unbound_typedef of string
+ | No_member of string * string * string
+
+exception Error of error
+
+(* Maps over ident, accessible both by name or by name + stamp *)
+
+module StringMap = Map.Make(String)
+
+module IdentMap = struct
+ type 'a t = (ident * 'a) list StringMap.t
+ let empty : 'a t = StringMap.empty
+
+ (* Search by name and return topmost binding *)
+ let lookup s m =
+ match StringMap.find s m with
+ | id_data :: _ -> id_data
+ | [] -> assert false
+
+ (* Search by identifier and return associated binding *)
+ let find id m =
+ let rec lookup_in = function
+ | [] -> raise Not_found
+ | (id', data) :: rem ->
+ if id'.stamp = id.stamp then data else lookup_in rem in
+ lookup_in (StringMap.find id.name m)
+
+ (* Insert by identifier *)
+ let add id data m =
+ let l = try StringMap.find id.name m with Not_found -> [] in
+ StringMap.add id.name ((id, data) :: l) m
+end
+
+let gensym = ref 0
+
+let fresh_ident s = incr gensym; { name = s; stamp = !gensym }
+
+(* Infos associated with structs or unions *)
+
+type composite_info = {
+ ci_kind: struct_or_union;
+ ci_members: field list; (* members, in order *)
+ ci_alignof: int option; (* alignment; None if incomplete *)
+ ci_sizeof: int option; (* size; None if incomplete *)
+}
+
+(* Infos associated with an ordinary identifier *)
+
+type ident_info =
+ | II_ident of storage * typ
+ | II_enum of int64 (* value of the enum *)
+
+(* Infos associated with a typedef *)
+
+type typedef_info = typ
+
+(* Environments *)
+
+type t = {
+ env_scope: int;
+ env_ident: ident_info IdentMap.t;
+ env_tag: composite_info IdentMap.t;
+ env_typedef: typedef_info IdentMap.t
+}
+
+let empty = {
+ env_scope = 0;
+ env_ident = IdentMap.empty;
+ env_tag = IdentMap.empty;
+ env_typedef = IdentMap.empty
+}
+
+(* Enter a new scope. *)
+
+let new_scope env =
+ { env with env_scope = !gensym + 1 }
+
+let in_current_scope env id = id.stamp >= env.env_scope
+
+(* Looking up things by source name *)
+
+let lookup_ident env s =
+ try
+ IdentMap.lookup s env.env_ident
+ with Not_found ->
+ raise(Error(Unbound_identifier s))
+
+let lookup_tag env s =
+ try
+ IdentMap.lookup s env.env_tag
+ with Not_found ->
+ raise(Error(Unbound_tag(s, "tag")))
+
+let lookup_struct env s =
+ try
+ let (id, ci as res) = IdentMap.lookup s env.env_tag in
+ if ci.ci_kind <> Struct then
+ raise(Error(Tag_mismatch(s, "struct", "union")));
+ res
+ with Not_found ->
+ raise(Error(Unbound_tag(s, "struct")))
+
+let lookup_union env s =
+ try
+ let (id, ci as res) = IdentMap.lookup s env.env_tag in
+ if ci.ci_kind <> Union then
+ raise(Error(Tag_mismatch(s, "union", "struct")));
+ res
+ with Not_found ->
+ raise(Error(Unbound_tag(s, "union")))
+
+let lookup_composite env s =
+ try Some (IdentMap.lookup s env.env_tag)
+ with Not_found -> None
+
+let lookup_typedef env s =
+ try
+ IdentMap.lookup s env.env_typedef
+ with Not_found ->
+ raise(Error(Unbound_typedef s))
+
+(* Checking if a source name is bound *)
+
+let ident_is_bound env s = StringMap.mem s env.env_ident
+
+(* Finding things by translated identifier *)
+
+let find_ident env id =
+ try IdentMap.find id env.env_ident
+ with Not_found ->
+ raise(Error(Unbound_identifier(id.name)))
+
+let find_tag env id =
+ try IdentMap.find id env.env_tag
+ with Not_found ->
+ raise(Error(Unbound_tag(id.name, "tag")))
+
+let find_struct env id =
+ try
+ let ci = IdentMap.find id env.env_tag in
+ if ci.ci_kind <> Struct then
+ raise(Error(Tag_mismatch(id.name, "struct", "union")));
+ ci
+ with Not_found ->
+ raise(Error(Unbound_tag(id.name, "struct")))
+
+let find_union env id =
+ try
+ let ci = IdentMap.find id env.env_tag in
+ if ci.ci_kind <> Union then
+ raise(Error(Tag_mismatch(id.name, "union", "struct")));
+ ci
+ with Not_found ->
+ raise(Error(Unbound_tag(id.name, "union")))
+
+let find_member ci m =
+ List.find (fun f -> f.fld_name = m) ci
+
+let find_struct_member env (id, m) =
+ try
+ let ci = find_struct env id in
+ find_member ci.ci_members m
+ with Not_found ->
+ raise(Error(No_member(id.name, "struct", m)))
+
+let find_union_member env (id, m) =
+ try
+ let ci = find_union env id in
+ find_member ci.ci_members m
+ with Not_found ->
+ raise(Error(No_member(id.name, "union", m)))
+
+let find_typedef env id =
+ try
+ IdentMap.find id env.env_typedef
+ with Not_found ->
+ raise(Error(Unbound_typedef(id.name)))
+
+(* Inserting things by source name, with generation of a translated name *)
+
+let enter_ident env s sto ty =
+ let id = fresh_ident s in
+ (id,
+ { env with env_ident = IdentMap.add id (II_ident(sto, ty)) env.env_ident })
+
+let enter_composite env s ci =
+ let id = fresh_ident s in
+ (id, { env with env_tag = IdentMap.add id ci env.env_tag })
+
+let enter_enum_item env s v =
+ let id = fresh_ident s in
+ (id, { env with env_ident = IdentMap.add id (II_enum v) env.env_ident })
+
+let enter_typedef env s info =
+ let id = fresh_ident s in
+ (id, { env with env_typedef = IdentMap.add id info env.env_typedef })
+
+(* Inserting things by translated name *)
+
+let add_ident env id sto ty =
+ { env with env_ident = IdentMap.add id (II_ident(sto, ty)) env.env_ident }
+
+let add_composite env id ci =
+ { env with env_tag = IdentMap.add id ci env.env_tag }
+
+let add_typedef env id info =
+ { env with env_typedef = IdentMap.add id info env.env_typedef }
+
+(* Error reporting *)
+
+open Printf
+
+let error_message = function
+ | Unbound_identifier name ->
+ sprintf "Unbound identifier '%s'" name
+ | Unbound_tag(name, kind) ->
+ sprintf "Unbound %s '%s'" kind name
+ | Tag_mismatch(name, expected, actual) ->
+ sprintf "'%s' was declared as a %s but is used as a %s"
+ name actual expected
+ | Unbound_typedef name ->
+ sprintf "Unbound typedef '%s'" name
+ | No_member(compname, compkind, memname) ->
+ sprintf "%s '%s' has no member named '%s'"
+ compkind compname memname
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+type error =
+ Unbound_identifier of string
+ | Unbound_tag of string * string
+ | Tag_mismatch of string * string * string
+ | Unbound_typedef of string
+ | No_member of string * string * string
+val error_message : error -> string
+exception Error of error
+
+val fresh_ident : string -> C.ident
+
+type composite_info = {
+ ci_kind: C.struct_or_union;
+ ci_members: C.field list; (* members, in order *)
+ ci_alignof: int option; (* alignment; None if incomplete *)
+ ci_sizeof: int option; (* size; None if incomplete *)
+}
+
+type ident_info = II_ident of C.storage * C.typ | II_enum of int64
+
+type typedef_info = C.typ
+
+type t
+
+val empty : t
+
+val new_scope : t -> t
+val in_current_scope : t -> C.ident -> bool
+
+val lookup_ident : t -> string -> C.ident * ident_info
+val lookup_tag : t -> string -> C.ident * composite_info
+val lookup_struct : t -> string -> C.ident * composite_info
+val lookup_union : t -> string -> C.ident * composite_info
+val lookup_composite : t -> string -> (C.ident * composite_info) option
+val lookup_typedef : t -> string -> C.ident * typedef_info
+
+val ident_is_bound : t -> string -> bool
+
+val find_ident : t -> C.ident -> ident_info
+val find_tag : t -> C.ident -> composite_info
+val find_struct : t -> C.ident -> composite_info
+val find_union : t -> C.ident -> composite_info
+val find_member : C.field list -> string -> C.field
+val find_struct_member : t -> C.ident * string -> C.field
+val find_union_member : t -> C.ident * string -> C.field
+val find_typedef : t -> C.ident -> typedef_info
+
+val enter_ident : t -> string -> C.storage -> C.typ -> C.ident * t
+val enter_composite : t -> string -> composite_info -> C.ident * t
+val enter_enum_item : t -> string -> int64 -> C.ident * t
+val enter_typedef : t -> string -> typedef_info -> C.ident * t
+
+val add_ident : t -> C.ident -> C.storage -> C.typ -> t
+val add_composite : t -> C.ident -> composite_info -> t
+val add_typedef : t -> C.ident -> typedef_info -> t
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Management of errors and warnings *)
+
+open Format
+
+let warn_error = ref false
+
+let num_errors = ref 0
+let num_warnings = ref 0
+
+let reset () = num_errors := 0; num_warnings := 0
+
+exception Abort
+
+let fatal_error fmt =
+ incr num_errors;
+ kfprintf
+ (fun _ -> raise Abort)
+ err_formatter
+ ("@[<hov 2>" ^^ fmt ^^ ".@]@.@[<hov 0>Fatal error.@]@.")
+
+let error fmt =
+ incr num_errors;
+ eprintf ("@[<hov 2>" ^^ fmt ^^ ".@]@.")
+
+let warning fmt =
+ incr num_warnings;
+ eprintf ("@[<hov 2>" ^^ fmt ^^ ".@]@.")
+
+let check_errors () =
+ if !num_errors > 0 then
+ eprintf "@[<hov 0>%d error%s detected.@]@."
+ !num_errors
+ (if !num_errors = 1 then "" else "s");
+ if !warn_error && !num_warnings > 0 then
+ eprintf "@[<hov 0>%d error-enabled warning%s detected.@]@."
+ !num_warnings
+ (if !num_warnings = 1 then "" else "s");
+ !num_errors > 0 || (!warn_error && !num_warnings > 0)
+
+
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val warn_error : bool ref
+val reset : unit -> unit
+exception Abort
+val fatal_error : ('a, Format.formatter, unit, unit, unit, 'b) format6 -> 'a
+val error : ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
+val warning : ('a, Format.formatter, unit, unit, unit, unit) format6 -> 'a
+val check_errors : unit -> bool
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* GCC built-ins *)
+
+open C
+open Cutil
+
+(* Code adapted from CIL *)
+
+let voidType = TVoid []
+let charType = TInt(IChar, [])
+let intType = TInt(IInt, [])
+let uintType = TInt(IUInt, [])
+let longType = TInt(ILong, [])
+let ulongType = TInt(IULong, [])
+let ulongLongType = TInt(IULongLong, [])
+let floatType = TFloat(FFloat, [])
+let doubleType = TFloat(FDouble, [])
+let longDoubleType = TFloat (FLongDouble, [])
+let voidPtrType = TPtr(TVoid [], [])
+let voidConstPtrType = TPtr(TVoid [AConst], [])
+let charPtrType = TPtr(TInt(IChar, []), [])
+let charConstPtrType = TPtr(TInt(IChar, [AConst]), [])
+let intPtrType = TPtr(TInt(IInt, []), [])
+let sizeType = TInt(size_t_ikind, [])
+
+let builtins = {
+ Builtins.typedefs = [
+ "__builtin_va_list", voidPtrType
+];
+ Builtins.functions = [
+ "__builtin___fprintf_chk", (intType, [ voidPtrType; intType; charConstPtrType ], true) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
+ "__builtin___memcpy_chk", (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
+ "__builtin___memmove_chk", (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
+ "__builtin___mempcpy_chk", (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false);
+ "__builtin___memset_chk", (voidPtrType, [ voidPtrType; intType; sizeType; sizeType ], false);
+ "__builtin___printf_chk", (intType, [ intType; charConstPtrType ], true);
+ "__builtin___snprintf_chk", (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType ], true);
+ "__builtin___sprintf_chk", (intType, [ charPtrType; intType; sizeType; charConstPtrType ], true);
+ "__builtin___stpcpy_chk", (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ "__builtin___strcat_chk", (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ "__builtin___strcpy_chk", (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ "__builtin___strncat_chk", (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false);
+ "__builtin___strncpy_chk", (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false);
+ "__builtin___vfprintf_chk", (intType, [ voidPtrType; intType; charConstPtrType; voidPtrType ], false) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *);
+ "__builtin___vprintf_chk", (intType, [ intType; charConstPtrType; voidPtrType ], false);
+ "__builtin___vsnprintf_chk", (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType; voidPtrType ], false);
+ "__builtin___vsprintf_chk", (intType, [ charPtrType; intType; sizeType; charConstPtrType; voidPtrType ], false);
+
+ "__builtin_acos", (doubleType, [ doubleType ], false);
+ "__builtin_acosf", (floatType, [ floatType ], false);
+ "__builtin_acosl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_alloca", (voidPtrType, [ uintType ], false);
+
+ "__builtin_asin", (doubleType, [ doubleType ], false);
+ "__builtin_asinf", (floatType, [ floatType ], false);
+ "__builtin_asinl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_atan", (doubleType, [ doubleType ], false);
+ "__builtin_atanf", (floatType, [ floatType ], false);
+ "__builtin_atanl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_atan2", (doubleType, [ doubleType; doubleType ], false);
+ "__builtin_atan2f", (floatType, [ floatType; floatType ], false);
+ "__builtin_atan2l", (longDoubleType, [ longDoubleType;
+ longDoubleType ], false);
+
+ "__builtin_ceil", (doubleType, [ doubleType ], false);
+ "__builtin_ceilf", (floatType, [ floatType ], false);
+ "__builtin_ceill", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_cos", (doubleType, [ doubleType ], false);
+ "__builtin_cosf", (floatType, [ floatType ], false);
+ "__builtin_cosl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_cosh", (doubleType, [ doubleType ], false);
+ "__builtin_coshf", (floatType, [ floatType ], false);
+ "__builtin_coshl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_clz", (intType, [ uintType ], false);
+ "__builtin_clzl", (intType, [ ulongType ], false);
+ "__builtin_clzll", (intType, [ ulongLongType ], false);
+ "__builtin_constant_p", (intType, [ intType ], false);
+ "__builtin_ctz", (intType, [ uintType ], false);
+ "__builtin_ctzl", (intType, [ ulongType ], false);
+ "__builtin_ctzll", (intType, [ ulongLongType ], false);
+
+ "__builtin_exp", (doubleType, [ doubleType ], false);
+ "__builtin_expf", (floatType, [ floatType ], false);
+ "__builtin_expl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_expect", (longType, [ longType; longType ], false);
+
+ "__builtin_fabs", (doubleType, [ doubleType ], false);
+ "__builtin_fabsf", (floatType, [ floatType ], false);
+ "__builtin_fabsl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_ffs", (intType, [ uintType ], false);
+ "__builtin_ffsl", (intType, [ ulongType ], false);
+ "__builtin_ffsll", (intType, [ ulongLongType ], false);
+ "__builtin_frame_address", (voidPtrType, [ uintType ], false);
+
+ "__builtin_floor", (doubleType, [ doubleType ], false);
+ "__builtin_floorf", (floatType, [ floatType ], false);
+ "__builtin_floorl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_huge_val", (doubleType, [], false);
+ "__builtin_huge_valf", (floatType, [], false);
+ "__builtin_huge_vall", (longDoubleType, [], false);
+ "__builtin_inf", (doubleType, [], false);
+ "__builtin_inff", (floatType, [], false);
+ "__builtin_infl", (longDoubleType, [], false);
+ "__builtin_memcpy", (voidPtrType, [ voidPtrType; voidConstPtrType; uintType ], false);
+ "__builtin_mempcpy", (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false);
+
+ "__builtin_fmod", (doubleType, [ doubleType ], false);
+ "__builtin_fmodf", (floatType, [ floatType ], false);
+ "__builtin_fmodl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_frexp", (doubleType, [ doubleType; intPtrType ], false);
+ "__builtin_frexpf", (floatType, [ floatType; intPtrType ], false);
+ "__builtin_frexpl", (longDoubleType, [ longDoubleType;
+ intPtrType ], false);
+
+ "__builtin_ldexp", (doubleType, [ doubleType; intType ], false);
+ "__builtin_ldexpf", (floatType, [ floatType; intType ], false);
+ "__builtin_ldexpl", (longDoubleType, [ longDoubleType;
+ intType ], false);
+
+ "__builtin_log", (doubleType, [ doubleType ], false);
+ "__builtin_logf", (floatType, [ floatType ], false);
+ "__builtin_logl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_log10", (doubleType, [ doubleType ], false);
+ "__builtin_log10f", (floatType, [ floatType ], false);
+ "__builtin_log10l", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_modff", (floatType, [ floatType;
+ TPtr(floatType,[]) ], false);
+ "__builtin_modfl", (longDoubleType, [ longDoubleType;
+ TPtr(longDoubleType, []) ],
+ false);
+
+ "__builtin_nan", (doubleType, [ charConstPtrType ], false);
+ "__builtin_nanf", (floatType, [ charConstPtrType ], false);
+ "__builtin_nanl", (longDoubleType, [ charConstPtrType ], false);
+ "__builtin_nans", (doubleType, [ charConstPtrType ], false);
+ "__builtin_nansf", (floatType, [ charConstPtrType ], false);
+ "__builtin_nansl", (longDoubleType, [ charConstPtrType ], false);
+ "__builtin_next_arg", (voidPtrType, [], false);
+ "__builtin_object_size", (sizeType, [ voidPtrType; intType ], false);
+
+ "__builtin_parity", (intType, [ uintType ], false);
+ "__builtin_parityl", (intType, [ ulongType ], false);
+ "__builtin_parityll", (intType, [ ulongLongType ], false);
+
+ "__builtin_popcount", (intType, [ uintType ], false);
+ "__builtin_popcountl", (intType, [ ulongType ], false);
+ "__builtin_popcountll", (intType, [ ulongLongType ], false);
+
+ "__builtin_powi", (doubleType, [ doubleType; intType ], false);
+ "__builtin_powif", (floatType, [ floatType; intType ], false);
+ "__builtin_powil", (longDoubleType, [ longDoubleType; intType ], false);
+ "__builtin_prefetch", (voidType, [ voidConstPtrType ], true);
+ "__builtin_return", (voidType, [ voidConstPtrType ], false);
+ "__builtin_return_address", (voidPtrType, [ uintType ], false);
+
+ "__builtin_sin", (doubleType, [ doubleType ], false);
+ "__builtin_sinf", (floatType, [ floatType ], false);
+ "__builtin_sinl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_sinh", (doubleType, [ doubleType ], false);
+ "__builtin_sinhf", (floatType, [ floatType ], false);
+ "__builtin_sinhl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_sqrt", (doubleType, [ doubleType ], false);
+ "__builtin_sqrtf", (floatType, [ floatType ], false);
+ "__builtin_sqrtl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_stpcpy", (charPtrType, [ charPtrType; charConstPtrType ], false);
+ "__builtin_strchr", (charPtrType, [ charPtrType; charType ], false);
+ "__builtin_strcmp", (intType, [ charConstPtrType; charConstPtrType ], false);
+ "__builtin_strcpy", (charPtrType, [ charPtrType; charConstPtrType ], false);
+ "__builtin_strcspn", (uintType, [ charConstPtrType; charConstPtrType ], false);
+ "__builtin_strncat", (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ "__builtin_strncmp", (intType, [ charConstPtrType; charConstPtrType; sizeType ], false);
+ "__builtin_strncpy", (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false);
+ "__builtin_strspn", (intType, [ charConstPtrType; charConstPtrType ], false);
+ "__builtin_strpbrk", (charPtrType, [ charConstPtrType; charConstPtrType ], false);
+ (* When we parse builtin_types_compatible_p, we change its interface *)
+ "__builtin_types_compatible_p",
+ (intType, [ uintType; (* Sizeof the type *)
+ uintType (* Sizeof the type *) ],
+ false);
+ "__builtin_tan", (doubleType, [ doubleType ], false);
+ "__builtin_tanf", (floatType, [ floatType ], false);
+ "__builtin_tanl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_tanh", (doubleType, [ doubleType ], false);
+ "__builtin_tanhf", (floatType, [ floatType ], false);
+ "__builtin_tanhl", (longDoubleType, [ longDoubleType ], false);
+
+ "__builtin_va_end", (voidType, [ voidPtrType ], false);
+ "__builtin_varargs_start",
+ (voidType, [ voidPtrType ], false);
+ (* When we elaborate builtin_stdarg_start/builtin_va_start,
+ second argument is passed by address *)
+ "__builtin_va_start", (voidType, [ voidPtrType; voidPtrType ], false);
+ "__builtin_stdarg_start", (voidType, [ voidPtrType ], false);
+ (* When we parse builtin_va_arg, type argument becomes sizeof type *)
+ "__builtin_va_arg", (voidType, [ voidPtrType; sizeType ], false);
+ "__builtin_va_copy", (voidType, [ voidPtrType;
+ voidPtrType ],
+ false)
+]
+}
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* GCC built-ins *)
+
+val builtins: Builtins.t
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2002,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * 3. The names of the contributors may not be used to endorse or promote
+ * products derived from this software without specific prior written
+ * permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ *)
+
+
+(* This interface is generated manually. The corresponding .ml file is
+ * generated automatically and is placed in ../obj/clexer.ml. The reason we
+ * want this interface is to avoid confusing make with freshly generated
+ * interface files *)
+
+
+val init: filename:string -> in_channel -> Lexing.lexbuf
+val finish: unit -> unit
+
+(* This is the main parser function *)
+val initial: Lexing.lexbuf -> Parser.token
+
+
+val push_context: unit -> unit (* Start a context *)
+val add_type: string -> unit (* Add a new string as a type name *)
+val add_identifier: string -> unit (* Add a new string as a variable name *)
+val pop_context: unit -> unit (* Remove all names added in this context *)
+
--- /dev/null
+(*
+ *
+ * Copyright (c) 2001-2003,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * Ben Liblit <liblit@cs.berkeley.edu>
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * 3. The names of the contributors may not be used to endorse or promote
+ * products derived from this software without specific prior written
+ * permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ *)
+(* FrontC -- lexical analyzer
+**
+** 1.0 3.22.99 Hugues Cassé First version.
+** 2.0 George Necula 12/12/00: Many extensions
+*)
+{
+open Lexing
+open Parse_aux
+open Parser
+
+exception Eof
+
+module H = Hashtbl
+
+let newline lb =
+ let cp = lb.lex_curr_p in
+ lb.lex_curr_p <- { cp with pos_lnum = 1 + cp.pos_lnum }
+
+let setCurrentLine lb lineno =
+ let cp = lb.lex_curr_p in
+ lb.lex_curr_p <- { cp with pos_lnum = lineno }
+
+let setCurrentFile lb file =
+ let cp = lb.lex_curr_p in
+ lb.lex_curr_p <- { cp with pos_fname = file }
+
+let matchingParsOpen = ref 0
+
+let currentLoc = Cabshelper.currentLoc_lexbuf
+
+let int64_to_char value =
+ assert (value <= 255L && value >= 0L);
+ Char.chr (Int64.to_int value)
+
+(* takes a not-nul-terminated list, and converts it to a string. *)
+let rec intlist_to_string (str: int64 list):string =
+ match str with
+ [] -> "" (* add nul-termination *)
+ | value::rest ->
+ let this_char = int64_to_char value in
+ (String.make 1 this_char) ^ (intlist_to_string rest)
+
+(*
+** Keyword hashtable
+*)
+let lexicon = H.create 211
+let init_lexicon _ =
+ H.clear lexicon;
+ List.iter
+ (fun (key, builder) -> H.add lexicon key builder)
+ [ ("_Bool", fun loc -> UNDERSCORE_BOOL loc);
+ ("auto", fun loc -> AUTO loc);
+ ("const", fun loc -> CONST loc);
+ ("__const", fun loc -> CONST loc);
+ ("__const__", fun loc -> CONST loc);
+ ("static", fun loc -> STATIC loc);
+ ("extern", fun loc -> EXTERN loc);
+ ("long", fun loc -> LONG loc);
+ ("short", fun loc -> SHORT loc);
+ ("register", fun loc -> REGISTER loc);
+ ("signed", fun loc -> SIGNED loc);
+ ("__signed", fun loc -> SIGNED loc);
+ ("unsigned", fun loc -> UNSIGNED loc);
+ ("volatile", fun loc -> VOLATILE loc);
+ ("__volatile", fun loc -> VOLATILE loc);
+ (* WW: see /usr/include/sys/cdefs.h for why __signed and __volatile
+ * are accepted GCC-isms *)
+ ("char", fun loc -> CHAR loc);
+ ("int", fun loc -> INT loc);
+ ("float", fun loc -> FLOAT loc);
+ ("double", fun loc -> DOUBLE loc);
+ ("void", fun loc -> VOID loc);
+ ("enum", fun loc -> ENUM loc);
+ ("struct", fun loc -> STRUCT loc);
+ ("typedef", fun loc -> TYPEDEF loc);
+ ("union", fun loc -> UNION loc);
+ ("break", fun loc -> BREAK loc);
+ ("continue", fun loc -> CONTINUE loc);
+ ("goto", fun loc -> GOTO loc);
+ ("return", fun loc -> RETURN loc);
+ ("switch", fun loc -> SWITCH loc);
+ ("case", fun loc -> CASE loc);
+ ("default", fun loc -> DEFAULT loc);
+ ("while", fun loc -> WHILE loc);
+ ("do", fun loc -> DO loc);
+ ("for", fun loc -> FOR loc);
+ ("if", fun loc -> IF loc);
+ ("else", fun _ -> ELSE);
+ (*** Implementation specific keywords ***)
+ ("__signed__", fun loc -> SIGNED loc);
+ ("__inline__", fun loc -> INLINE loc);
+ ("inline", fun loc -> INLINE loc);
+ ("__inline", fun loc -> INLINE loc);
+ ("_inline", fun loc ->
+ if !msvcMode then
+ INLINE loc
+ else
+ IDENT ("_inline", loc));
+ ("__attribute__", fun loc -> ATTRIBUTE loc);
+ ("__attribute", fun loc -> ATTRIBUTE loc);
+(*
+ ("__attribute_used__", fun loc -> ATTRIBUTE_USED loc);
+*)
+ ("__blockattribute__", fun _ -> BLOCKATTRIBUTE);
+ ("__blockattribute", fun _ -> BLOCKATTRIBUTE);
+ ("__asm__", fun loc -> ASM loc);
+ ("asm", fun loc -> ASM loc);
+ ("__typeof__", fun loc -> TYPEOF loc);
+ ("__typeof", fun loc -> TYPEOF loc);
+ ("typeof", fun loc -> TYPEOF loc);
+ ("__alignof", fun loc -> ALIGNOF loc);
+ ("__alignof__", fun loc -> ALIGNOF loc);
+ ("__volatile__", fun loc -> VOLATILE loc);
+ ("__volatile", fun loc -> VOLATILE loc);
+
+ ("__FUNCTION__", fun loc -> FUNCTION__ loc);
+ ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *)
+ ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc);
+ ("__label__", fun _ -> LABEL__);
+ (*** weimer: GCC arcana ***)
+ ("__restrict", fun loc -> RESTRICT loc);
+ ("restrict", fun loc -> RESTRICT loc);
+(* ("__extension__", EXTENSION); *)
+ (**** MS VC ***)
+ ("__int64", fun loc -> INT64 loc);
+ ("__int32", fun loc -> INT loc);
+ ("_cdecl", fun loc -> MSATTR ("_cdecl", loc));
+ ("__cdecl", fun loc -> MSATTR ("__cdecl", loc));
+ ("_stdcall", fun loc -> MSATTR ("_stdcall", loc));
+ ("__stdcall", fun loc -> MSATTR ("__stdcall", loc));
+ ("_fastcall", fun loc -> MSATTR ("_fastcall", loc));
+ ("__fastcall", fun loc -> MSATTR ("__fastcall", loc));
+ ("__w64", fun loc -> MSATTR("__w64", loc));
+ ("__declspec", fun loc -> DECLSPEC loc);
+ ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline
+ * into inline *)
+ ("__try", fun loc -> TRY loc);
+ ("__except", fun loc -> EXCEPT loc);
+ ("__finally", fun loc -> FINALLY loc);
+ (* weimer: some files produced by 'GCC -E' expect this type to be
+ * defined *)
+ ("__builtin_va_list", fun loc -> NAMED_TYPE ("__builtin_va_list", loc));
+ ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc);
+ ("__builtin_types_compatible_p", fun loc -> BUILTIN_TYPES_COMPAT loc);
+ ("__builtin_offsetof", fun loc -> BUILTIN_OFFSETOF loc);
+ (* On some versions of GCC __thread is a regular identifier *)
+ ("__thread", fun loc -> THREAD loc)
+ ]
+
+(* Mark an identifier as a type name. The old mapping is preserved and will
+ * be reinstated when we exit this context *)
+let add_type name =
+ (* ignore (print_string ("adding type name " ^ name ^ "\n")); *)
+ H.add lexicon name (fun loc -> NAMED_TYPE (name, loc))
+
+let context : string list list ref = ref []
+
+let push_context _ = context := []::!context
+
+let pop_context _ =
+ match !context with
+ [] -> assert false
+ | con::sub ->
+ (context := sub;
+ List.iter (fun name ->
+ (* ignore (print_string ("removing lexicon for " ^ name ^ "\n")); *)
+ H.remove lexicon name) con)
+
+(* Mark an identifier as a variable name. The old mapping is preserved and
+ * will be reinstated when we exit this context *)
+let add_identifier name =
+ match !context with
+ [] -> () (* Just ignore raise (InternalError "Empty context stack") *)
+ | con::sub ->
+ context := (name::con)::sub;
+ H.add lexicon name (fun loc -> IDENT (name, loc))
+
+
+(*
+** Useful primitives
+*)
+let scan_ident lb id =
+ let here = currentLoc lb in
+ try (H.find lexicon id) here
+ (* default to variable name, as opposed to type *)
+ with Not_found -> IDENT (id, here)
+
+
+(*
+** Buffer processor
+*)
+
+
+let init ~(filename: string) ic : Lexing.lexbuf =
+ init_lexicon ();
+ (* Inititialize the pointer in Errormsg *)
+ Parse_aux.add_type := add_type;
+ Parse_aux.push_context := push_context;
+ Parse_aux.pop_context := pop_context;
+ Parse_aux.add_identifier := add_identifier;
+ (* Build lexbuf *)
+ let lb = Lexing.from_channel ic in
+ let cp = lb.lex_curr_p in
+ lb.lex_curr_p <- {cp with pos_fname = filename; pos_lnum = 1};
+ lb
+
+let finish () =
+ ()
+
+(*** Error handling ***)
+let error = parse_error
+
+
+(*** escape character management ***)
+let scan_escape (char: char) : int64 =
+ let result = match char with
+ 'n' -> '\n'
+ | 'r' -> '\r'
+ | 't' -> '\t'
+ | 'b' -> '\b'
+ | 'f' -> '\012' (* ASCII code 12 *)
+ | 'v' -> '\011' (* ASCII code 11 *)
+ | 'a' -> '\007' (* ASCII code 7 *)
+ | 'e' | 'E' -> '\027' (* ASCII code 27. This is a GCC extension *)
+ | '\'' -> '\''
+ | '"'-> '"' (* '"' *)
+ | '?' -> '?'
+ | '(' when not !msvcMode -> '('
+ | '{' when not !msvcMode -> '{'
+ | '[' when not !msvcMode -> '['
+ | '%' when not !msvcMode -> '%'
+ | '\\' -> '\\'
+ | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other)); raise Parsing.Parse_error
+ in
+ Int64.of_int (Char.code result)
+
+let scan_hex_escape str =
+ let radix = Int64.of_int 16 in
+ let the_value = ref Int64.zero in
+ (* start at character 2 to skip the \x *)
+ for i = 2 to (String.length str) - 1 do
+ let thisDigit = Cabshelper.valueOfDigit (String.get str i) in
+ (* the_value := !the_value * 16 + thisDigit *)
+ the_value := Int64.add (Int64.mul !the_value radix) thisDigit
+ done;
+ !the_value
+
+let scan_oct_escape str =
+ let radix = Int64.of_int 8 in
+ let the_value = ref Int64.zero in
+ (* start at character 1 to skip the \x *)
+ for i = 1 to (String.length str) - 1 do
+ let thisDigit = Cabshelper.valueOfDigit (String.get str i) in
+ (* the_value := !the_value * 8 + thisDigit *)
+ the_value := Int64.add (Int64.mul !the_value radix) thisDigit
+ done;
+ !the_value
+
+let lex_hex_escape remainder lexbuf =
+ let prefix = scan_hex_escape (Lexing.lexeme lexbuf) in
+ prefix :: remainder lexbuf
+
+let lex_oct_escape remainder lexbuf =
+ let prefix = scan_oct_escape (Lexing.lexeme lexbuf) in
+ prefix :: remainder lexbuf
+
+let lex_simple_escape remainder lexbuf =
+ let lexchar = Lexing.lexeme_char lexbuf 1 in
+ let prefix = scan_escape lexchar in
+ prefix :: remainder lexbuf
+
+let lex_unescaped remainder lexbuf =
+ let prefix = Int64.of_int (Char.code (Lexing.lexeme_char lexbuf 0)) in
+ prefix :: remainder lexbuf
+
+let lex_comment remainder lexbuf =
+ let ch = Lexing.lexeme_char lexbuf 0 in
+ let prefix = Int64.of_int (Char.code ch) in
+ if ch = '\n' then newline lexbuf;
+ prefix :: remainder lexbuf
+
+let make_char (i:int64):char =
+ let min_val = Int64.zero in
+ let max_val = Int64.of_int 255 in
+ (* if i < 0 || i > 255 then error*)
+ if compare i min_val < 0 || compare i max_val > 0 then begin
+ let msg = Printf.sprintf "clexer:make_char: character 0x%Lx too big" i in
+ error msg
+ end;
+ Char.chr (Int64.to_int i)
+
+
+(* ISO standard locale-specific function to convert a wide character
+ * into a sequence of normal characters. Here we work on strings.
+ * We convert L"Hi" to "H\000i\000"
+ matth: this seems unused.
+let wbtowc wstr =
+ let len = String.length wstr in
+ let dest = String.make (len * 2) '\000' in
+ for i = 0 to len-1 do
+ dest.[i*2] <- wstr.[i] ;
+ done ;
+ dest
+*)
+
+(* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' }
+ matth: this seems unused.
+let wstr_to_warray wstr =
+ let len = String.length wstr in
+ let res = ref "{ " in
+ for i = 0 to len-1 do
+ res := !res ^ (Printf.sprintf "L'%c', " wstr.[i])
+ done ;
+ res := !res ^ "}" ;
+ !res
+*)
+
+}
+
+let decdigit = ['0'-'9']
+let octdigit = ['0'-'7']
+let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F']
+let letter = ['a'- 'z' 'A'-'Z']
+
+
+let usuffix = ['u' 'U']
+let lsuffix = "l"|"L"|"ll"|"LL"
+let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix
+ | usuffix ? "i64"
+
+
+let hexprefix = '0' ['x' 'X']
+
+let intnum = decdigit+ intsuffix?
+let octnum = '0' octdigit+ intsuffix?
+let hexnum = hexprefix hexdigit+ intsuffix?
+
+let exponent = ['e' 'E']['+' '-']? decdigit+
+let fraction = '.' decdigit+
+let decfloat = (intnum? fraction)
+ |(intnum exponent)
+ |(intnum? fraction exponent)
+ | (intnum '.')
+ | (intnum '.' exponent)
+
+let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+
+let binexponent = ['p' 'P'] ['+' '-']? decdigit+
+let hexfloat = hexprefix hexfraction binexponent
+ | hexprefix hexdigit+ binexponent
+
+let floatsuffix = ['f' 'F' 'l' 'L']
+let floatnum = (decfloat | hexfloat) floatsuffix?
+
+let ident = (letter|'_'|'$')(letter|decdigit|'_'|'$')*
+let blank = [' ' '\t' '\012' '\r']+
+let escape = '\\' _
+let hex_escape = '\\' ['x' 'X'] hexdigit+
+let oct_escape = '\\' octdigit octdigit? octdigit?
+
+rule initial =
+ parse "/*" { comment lexbuf;
+ initial lexbuf}
+| "//" { onelinecomment lexbuf;
+ newline lexbuf;
+ initial lexbuf
+ }
+| blank { initial lexbuf}
+| '\n' { newline lexbuf;
+ initial lexbuf }
+| '\\' '\r' * '\n' { newline lexbuf;
+ initial lexbuf
+ }
+| '#' { hash lexbuf}
+(*
+| "_Pragma" { PRAGMA (currentLoc lexbuf) }
+*)
+| '\'' { CST_CHAR (chr lexbuf, currentLoc lexbuf)}
+| "L'" { CST_WCHAR (chr lexbuf, currentLoc lexbuf) }
+| '"' { (* '"' *)
+(* matth: BUG: this could be either a regular string or a wide string.
+ * e.g. if it's the "world" in
+ * L"Hello, " "world"
+ * then it should be treated as wide even though there's no L immediately
+ * preceding it. See test/small1/wchar5.c for a failure case. *)
+ CST_STRING (str lexbuf, currentLoc lexbuf) }
+| "L\"" { (* weimer: wchar_t string literal *)
+ CST_WSTRING(str lexbuf, currentLoc lexbuf) }
+| floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc lexbuf)}
+| hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc lexbuf)}
+| octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc lexbuf)}
+| intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc lexbuf)}
+| "!quit!" {EOF}
+| "..." {ELLIPSIS}
+| "+=" {PLUS_EQ}
+| "-=" {MINUS_EQ}
+| "*=" {STAR_EQ}
+| "/=" {SLASH_EQ}
+| "%=" {PERCENT_EQ}
+| "|=" {PIPE_EQ}
+| "&=" {AND_EQ}
+| "^=" {CIRC_EQ}
+| "<<=" {INF_INF_EQ}
+| ">>=" {SUP_SUP_EQ}
+| "<<" {INF_INF}
+| ">>" {SUP_SUP}
+| "==" {EQ_EQ}
+| "!=" {EXCLAM_EQ}
+| "<=" {INF_EQ}
+| ">=" {SUP_EQ}
+| "=" {EQ}
+| "<" {INF}
+| ">" {SUP}
+| "++" {PLUS_PLUS (currentLoc lexbuf)}
+| "--" {MINUS_MINUS (currentLoc lexbuf)}
+| "->" {ARROW}
+| '+' {PLUS (currentLoc lexbuf)}
+| '-' {MINUS (currentLoc lexbuf)}
+| '*' {STAR (currentLoc lexbuf)}
+| '/' {SLASH}
+| '%' {PERCENT}
+| '!' {EXCLAM (currentLoc lexbuf)}
+| "&&" {AND_AND (currentLoc lexbuf)}
+| "||" {PIPE_PIPE}
+| '&' {AND (currentLoc lexbuf)}
+| '|' {PIPE}
+| '^' {CIRC}
+| '?' {QUEST}
+| ':' {COLON}
+| '~' {TILDE (currentLoc lexbuf)}
+
+| '{' {LBRACE (currentLoc lexbuf)}
+| '}' {RBRACE (currentLoc lexbuf)}
+| '[' {LBRACKET}
+| ']' {RBRACKET}
+| '(' { (LPAREN (currentLoc lexbuf)) }
+| ')' {RPAREN}
+| ';' { (SEMICOLON (currentLoc lexbuf)) }
+| ',' {COMMA}
+| '.' {DOT}
+| "sizeof" {SIZEOF (currentLoc lexbuf)}
+| "__asm" { if !msvcMode then
+ MSASM (msasm lexbuf, currentLoc lexbuf)
+ else (ASM (currentLoc lexbuf)) }
+
+(* If we see __pragma we eat it and the matching parentheses as well *)
+| "__pragma" { matchingParsOpen := 0;
+ let _ = matchingpars lexbuf in
+ initial lexbuf
+ }
+
+(* __extension__ is a black. The parser runs into some conflicts if we let it
+ * pass *)
+| "__extension__" {initial lexbuf }
+| ident {scan_ident lexbuf (Lexing.lexeme lexbuf)}
+| eof {EOF}
+| _ {parse_error "Invalid symbol"; raise Parsing.Parse_error }
+and comment =
+ parse
+ "*/" { () }
+| eof { () }
+| '\n' { newline lexbuf; comment lexbuf }
+| _ { comment lexbuf }
+
+
+and onelinecomment = parse
+ '\n'|eof { () }
+| _ { onelinecomment lexbuf }
+
+and matchingpars = parse
+ '\n' { newline lexbuf; matchingpars lexbuf }
+| blank { matchingpars lexbuf }
+| '(' { incr matchingParsOpen; matchingpars lexbuf }
+| ')' { decr matchingParsOpen;
+ if !matchingParsOpen = 0 then
+ ()
+ else
+ matchingpars lexbuf
+ }
+| "/*" { comment lexbuf; matchingpars lexbuf}
+| '"' { (* '"' *)
+ let _ = str lexbuf in
+ matchingpars lexbuf
+ }
+| _ { matchingpars lexbuf }
+
+(* # <line number> <file name> ... *)
+and hash = parse
+ '\n' { newline lexbuf; initial lexbuf}
+| blank { hash lexbuf}
+| intnum { (* We are seeing a line number. This is the number for the
+ * next line *)
+ let s = Lexing.lexeme lexbuf in
+ begin try
+ setCurrentLine lexbuf (int_of_string s - 1)
+ with Failure ("int_of_string") ->
+ (* the int is too big. *)
+ ()
+ end;
+ (* A file name may follow *)
+ file lexbuf }
+| "line" { hash lexbuf } (* MSVC line number info *)
+| "pragma" blank
+ { let here = currentLoc lexbuf in
+ PRAGMA_LINE (pragma lexbuf, here)
+ }
+| _ { endline lexbuf}
+
+and file = parse
+ '\n' { newline lexbuf; initial lexbuf}
+| blank { file lexbuf}
+| '"' [^ '\012' '\t' '"']* '"' { (* '"' *)
+ let n = Lexing.lexeme lexbuf in
+ let n1 = String.sub n 1
+ ((String.length n) - 2) in
+ setCurrentFile lexbuf n1;
+ endline lexbuf}
+
+| _ { endline lexbuf}
+
+and endline = parse
+ '\n' { newline lexbuf; initial lexbuf}
+| eof { EOF }
+| _ { endline lexbuf}
+
+and pragma = parse
+ '\n' { newline lexbuf; "" }
+| _ { let cur = Lexing.lexeme lexbuf in
+ cur ^ (pragma lexbuf) }
+
+and str = parse
+ '"' {[]} (* no nul terminiation in CST_STRING '"' *)
+| hex_escape { lex_hex_escape str lexbuf}
+| oct_escape { lex_oct_escape str lexbuf}
+| escape { lex_simple_escape str lexbuf}
+| _ { lex_unescaped str lexbuf}
+
+and chr = parse
+ '\'' {[]}
+| hex_escape {lex_hex_escape chr lexbuf}
+| oct_escape {lex_oct_escape chr lexbuf}
+| escape {lex_simple_escape chr lexbuf}
+| _ {lex_unescaped chr lexbuf}
+
+and msasm = parse
+ blank { msasm lexbuf }
+| '{' { msasminbrace lexbuf }
+| _ { let cur = Lexing.lexeme lexbuf in
+ cur ^ (msasmnobrace lexbuf) }
+
+and msasminbrace = parse
+ '}' { "" }
+| _ { let cur = Lexing.lexeme lexbuf in
+ cur ^ (msasminbrace lexbuf) }
+and msasmnobrace = parse
+ ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <-
+ lexbuf.Lexing.lex_curr_pos - 1;
+ "" }
+| "__asm" { lexbuf.Lexing.lex_curr_pos <-
+ lexbuf.Lexing.lex_curr_pos - 5;
+ "" }
+| _ { let cur = Lexing.lexeme lexbuf in
+
+ cur ^ (msasmnobrace lexbuf) }
+
+{
+
+}
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Machine-dependent aspects *)
+
+type t = {
+ char_signed: bool;
+ sizeof_ptr: int;
+ sizeof_short: int;
+ sizeof_int: int;
+ sizeof_long: int;
+ sizeof_longlong: int;
+ sizeof_float: int;
+ sizeof_double: int;
+ sizeof_longdouble: int;
+ sizeof_void: int option;
+ sizeof_fun: int option;
+ sizeof_wchar: int;
+ sizeof_size_t: int;
+ sizeof_ptrdiff_t: int;
+ alignof_ptr: int;
+ alignof_short: int;
+ alignof_int: int;
+ alignof_long: int;
+ alignof_longlong: int;
+ alignof_float: int;
+ alignof_double: int;
+ alignof_longdouble: int;
+ alignof_void: int option;
+ alignof_fun: int option
+}
+
+let ilp32ll64 = {
+ char_signed = false;
+ sizeof_ptr = 4;
+ sizeof_short = 2;
+ sizeof_int = 4;
+ sizeof_long = 4;
+ sizeof_longlong = 8;
+ sizeof_float = 4;
+ sizeof_double = 8;
+ sizeof_longdouble = 16;
+ sizeof_void = None;
+ sizeof_fun = None;
+ sizeof_wchar = 4;
+ sizeof_size_t = 4;
+ sizeof_ptrdiff_t = 4;
+ alignof_ptr = 4;
+ alignof_short = 2;
+ alignof_int = 4;
+ alignof_long = 4;
+ alignof_longlong = 8;
+ alignof_float = 4;
+ alignof_double = 8;
+ alignof_longdouble = 16;
+ alignof_void = None;
+ alignof_fun = None
+}
+
+let i32lpll64 = {
+ char_signed = false;
+ sizeof_ptr = 8;
+ sizeof_short = 2;
+ sizeof_int = 4;
+ sizeof_long = 8;
+ sizeof_longlong = 8;
+ sizeof_float = 4;
+ sizeof_double = 8;
+ sizeof_longdouble = 16;
+ sizeof_void = None;
+ sizeof_fun = None;
+ sizeof_wchar = 4;
+ sizeof_size_t = 8;
+ sizeof_ptrdiff_t = 8;
+ alignof_ptr = 8;
+ alignof_short = 2;
+ alignof_int = 4;
+ alignof_long = 8;
+ alignof_longlong = 8;
+ alignof_float = 4;
+ alignof_double = 8;
+ alignof_longdouble = 16;
+ alignof_void = None;
+ alignof_fun = None
+}
+
+let il32pll64 = {
+ char_signed = false;
+ sizeof_ptr = 8;
+ sizeof_short = 2;
+ sizeof_int = 4;
+ sizeof_long = 4;
+ sizeof_longlong = 8;
+ sizeof_float = 4;
+ sizeof_double = 8;
+ sizeof_longdouble = 16;
+ sizeof_void = None;
+ sizeof_fun = None;
+ sizeof_wchar = 4;
+ sizeof_size_t = 8;
+ sizeof_ptrdiff_t = 8;
+ alignof_ptr = 8;
+ alignof_short = 2;
+ alignof_int = 4;
+ alignof_long = 4;
+ alignof_longlong = 8;
+ alignof_float = 4;
+ alignof_double = 8;
+ alignof_longdouble = 16;
+ alignof_void = None;
+ alignof_fun = None
+}
+
+let make_char_signed c = {c with char_signed = true}
+
+let gcc_extensions c =
+ { c with sizeof_void = Some 1; sizeof_fun = Some 1;
+ alignof_void = Some 1; alignof_fun = Some 1 }
+
+let config =
+ ref (match Sys.word_size with
+ | 32 -> ilp32ll64
+ | 64 -> if Sys.os_type = "Win32" then il32pll64 else i32lpll64
+ | _ -> assert false)
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Machine-dependent aspects *)
+
+type t = {
+ char_signed: bool;
+ sizeof_ptr: int;
+ sizeof_short: int;
+ sizeof_int: int;
+ sizeof_long: int;
+ sizeof_longlong: int;
+ sizeof_float: int;
+ sizeof_double: int;
+ sizeof_longdouble: int;
+ sizeof_void: int option;
+ sizeof_fun: int option;
+ sizeof_wchar: int;
+ sizeof_size_t: int;
+ sizeof_ptrdiff_t: int;
+ alignof_ptr: int;
+ alignof_short: int;
+ alignof_int: int;
+ alignof_long: int;
+ alignof_longlong: int;
+ alignof_float: int;
+ alignof_double: int;
+ alignof_longdouble: int;
+ alignof_void: int option;
+ alignof_fun: int option
+}
+
+val ilp32ll64 : t
+val i32lpll64 : t
+val il32pll64 : t
+val make_char_signed : t -> t
+val gcc_extensions : t -> t
+
+val config : t ref
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Wrapper around gcc to parse, transform, pretty-print, and call gcc on result *)
+
+let transfs = ref ""
+
+let safe_remove name =
+ try Sys.remove name with Sys_error _ -> ()
+
+let process_c_file prepro_opts name =
+ let ppname = Filename.temp_file "cparser" ".i" in
+ let cpname = Filename.chop_suffix name ".c" ^ ".i" in
+ let rc =
+ Sys.command
+ (Printf.sprintf "gcc -E -U__GNUC__ %s %s > %s"
+ (String.concat " " (List.map Filename.quote prepro_opts))
+ (Filename.quote name) (Filename.quote ppname)) in
+ if rc <> 0 then begin
+ safe_remove ppname;
+ exit 2
+ end;
+ let r = Parse.preprocessed_file !transfs name ppname in
+ safe_remove ppname;
+ match r with
+ | None -> exit 2
+ | Some p ->
+ let oc = open_out cpname in
+ let oform = Format.formatter_of_out_channel oc in
+ Cprint.program oform p;
+ close_out oc;
+ cpname
+
+let starts_with pref s =
+ String.length s >= String.length pref
+ && String.sub s 0 (String.length pref) = pref
+
+let ends_with suff s =
+ String.length s >= String.length suff
+ && String.sub s (String.length s - String.length suff) (String.length suff)
+ = suff
+
+let rec parse_cmdline prepro args i =
+ if i >= Array.length Sys.argv then List.rev args else begin
+ (* should skip arguments more cleanly... *)
+ let s = Sys.argv.(i) in
+ if s = "-Xsimplif" && i + 1 < Array.length Sys.argv then begin
+ transfs := Sys.argv.(i+1);
+ parse_cmdline prepro args (i+2)
+ end else if (s = "-I" || s = "-D" || s = "-U")
+ && i + 1 < Array.length Sys.argv then
+ parse_cmdline (Sys.argv.(i+1) :: s :: prepro) args (i+2)
+ else if starts_with "-I" s
+ || starts_with "-D" s
+ || starts_with "-U" s then
+ parse_cmdline (s :: prepro) args (i + 1)
+ else if s = "-Wall" then
+ parse_cmdline prepro ("-Wno-parentheses" :: "-Wall" :: args) (i+1)
+ else if ends_with ".c" s then begin
+ let s' = process_c_file (List.rev prepro) s in
+ parse_cmdline prepro (s' :: args) (i + 1)
+ end else
+ parse_cmdline prepro (s :: args) (i + 1)
+ end
+
+let _ =
+ Builtins.set GCC.builtins;
+ let args = parse_cmdline [] [] 1 in
+ let cmd = "gcc " ^ String.concat " " (List.map Filename.quote args) in
+ let rc = Sys.command cmd in
+ exit rc
--- /dev/null
+OCAMLC=ocamlc -g
+OCAMLOPT=ocamlopt -g
+OCAMLLEX=ocamllex
+OCAMLYACC=ocamlyacc -v
+OCAMLDEP=ocamldep
+OCAMLMKLIB=ocamlmklib
+
+LIBDIR=../lib
+
+INTFS=C.mli
+
+SRCS=Errors.ml Cabs.ml Cabshelper.ml Parse_aux.ml Parser.ml Lexer.ml \
+ Machine.ml \
+ Env.ml Cprint.ml Cutil.ml Ceval.ml \
+ Builtins.ml GCC.ml CBuiltins.ml \
+ Cleanup.ml Elab.ml Rename.ml \
+ Transform.ml \
+ Unblock.ml SimplExpr.ml AddCasts.ml StructByValue.ml StructAssign.ml \
+ Bitfields.ml \
+ Parse.ml
+
+COBJS=uint64.o
+BOBJS=$(SRCS:.ml=.cmo)
+NOBJS=$(SRCS:.ml=.cmx)
+IOBJS=$(INTFS:.mli=.cmi)
+NATIVETARGETS=$(shell if `which ocamlopt`; \
+ then echo "cparser.cmxa cparser cparser.a libcparser.a dllcparser.so"; fi)
+
+all: $(NATIVETARGETS) cparser.cma cparser.byte
+
+install:
+ mkdir -p $(LIBDIR)
+ cp -p Cparser.cmi cparser.cma $(NATIVETARGETS) $(LIBDIR)
+
+cparser: $(COBJS) $(NOBJS) Main.cmx
+ $(OCAMLOPT) -o cparser $(COBJS) $(NOBJS) Main.cmx
+
+cparser.byte: $(COBJS) $(BOBJS) Main.cmo
+ $(OCAMLC) -custom -o cparser.byte $(COBJS) $(BOBJS) Main.cmo
+
+cparser.cma libcparser.a: uint64.o Cparser.cmo
+ $(OCAMLMKLIB) -o cparser uint64.o Cparser.cmo
+
+cparser.cmxa: uint64.o Cparser.cmx
+ $(OCAMLMKLIB) -o cparser uint64.o Cparser.cmx
+
+Cparser.cmo Cparser.cmi: $(IOBJS) $(BOBJS)
+ $(OCAMLC) -pack -o Cparser.cmo $(IOBJS) $(BOBJS)
+
+Cparser.cmx: $(IOBJS) $(NOBJS)
+ $(OCAMLOPT) -pack -o Cparser.cmx $(IOBJS) $(NOBJS)
+
+Parser.ml Parser.mli: Parser.mly
+ $(OCAMLYACC) Parser.mly
+
+clean::
+ rm -f Parser.ml Parser.mli Parser.output
+
+beforedepend:: Parser.ml Parser.mli
+
+Lexer.ml: Lexer.mll
+ $(OCAMLLEX) Lexer.mll
+
+clean::
+ rm -f Lexer.ml
+
+beforedepend:: Lexer.ml
+
+.SUFFIXES: .ml .mli .cmi .cmo .cmx
+
+.mli.cmi:
+ $(OCAMLC) -c $*.mli
+.ml.cmo:
+ $(OCAMLC) -c $*.ml
+.ml.cmx:
+ $(OCAMLOPT) -c -for-pack Cparser $*.ml
+.c.o:
+ $(OCAMLC) -c $*.c
+
+clean::
+ rm -f *.cm? *.o *.so *.a *.cmxa *.byte cparser
+
+depend: beforedepend
+ $(OCAMLDEP) *.mli *.ml > .depend
+
+include .depend
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Entry point for the library: parse, elaborate, and transform *)
+
+module CharSet = Set.Make(struct type t = char let compare = compare end)
+
+let transform_program t p =
+ let run_pass pass flag p = if CharSet.mem flag t then pass p else p in
+ Rename.program
+ (run_pass (AddCasts.program ~all:(CharSet.mem 'C' t)) 'c'
+ (run_pass StructAssign.program 'S'
+ (run_pass StructByValue.program 's'
+ (run_pass Bitfields.program 'f'
+ (run_pass (SimplExpr.program ~volatile:(CharSet.mem 'v' t)) 'e'
+ (run_pass Unblock.program 'b'
+ p))))))
+
+let parse_transformations s =
+ let t = ref CharSet.empty in
+ let set s = String.iter (fun c -> t := CharSet.add c !t) s in
+ String.iter
+ (function 'b' -> set "b"
+ | 'e' -> set "e"
+ | 'c' -> set "ec"
+ | 'C' -> set "ecC"
+ | 's' -> set "s"
+ | 'S' -> set "esS"
+ | 'v' -> set "ev"
+ | 'f' -> set "bef"
+ | _ -> ())
+ s;
+ !t
+
+let preprocessed_file transfs name sourcefile =
+ Errors.reset();
+ let t = parse_transformations transfs in
+ let ic = open_in sourcefile in
+ let p =
+ try
+ Rename.program (transform_program t (Elab.elab_preprocessed_file name ic))
+ with Parsing.Parse_error ->
+ Errors.error "Error during parsing"; []
+ | Errors.Abort ->
+ [] in
+ close_in ic;
+ if Errors.check_errors() then None else Some p
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Entry point for the library: parse, elaborate, and transform *)
+
+val preprocessed_file: string -> string -> string -> C.program option
+
+(* first arg: desired transformations
+ second arg: source file name before preprocessing
+ third arg: file after preprocessing *)
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+open Format
+open Errors
+open Cabshelper
+
+(* Report parsing errors *)
+
+let parse_error msg =
+ error "%a: %s" format_cabsloc (currentLoc()) msg
+
+(* Are we parsing msvc syntax? *)
+
+let msvcMode = ref false
+
+(* We provide here a pointer to a function. It will be set by the lexer and
+ * used by the parser. In Ocaml lexers depend on parsers, so we we have put
+ * such functions in a separate module. *)
+let add_identifier: (string -> unit) ref =
+ ref (fun _ -> assert false)
+
+let add_type: (string -> unit) ref =
+ ref (fun _ -> assert false)
+
+let push_context: (unit -> unit) ref =
+ ref (fun _ -> assert false)
+
+let pop_context: (unit -> unit) ref =
+ ref (fun _ -> assert false)
+
+(* Keep here the current pattern for formatparse *)
+let currentPattern = ref ""
+
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val parse_error : string -> unit
+val msvcMode : bool ref
+val add_identifier : (string -> unit) ref
+val add_type : (string -> unit) ref
+val push_context : (unit -> unit) ref
+val pop_context : (unit -> unit) ref
+val currentPattern : string ref
--- /dev/null
+/*(*
+ *
+ * Copyright (c) 2001-2003,
+ * George C. Necula <necula@cs.berkeley.edu>
+ * Scott McPeak <smcpeak@cs.berkeley.edu>
+ * Wes Weimer <weimer@cs.berkeley.edu>
+ * Ben Liblit <liblit@cs.berkeley.edu>
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are
+ * met:
+ *
+ * 1. Redistributions of source code must retain the above copyright
+ * notice, this list of conditions and the following disclaimer.
+ *
+ * 2. Redistributions in binary form must reproduce the above copyright
+ * notice, this list of conditions and the following disclaimer in the
+ * documentation and/or other materials provided with the distribution.
+ *
+ * 3. The names of the contributors may not be used to endorse or promote
+ * products derived from this software without specific prior written
+ * permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
+ * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
+ * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
+ * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+ * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+ * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+ * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+ * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+ * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ *
+ **)
+(**
+** 1.0 3.22.99 Hugues Cassé First version.
+** 2.0 George Necula 12/12/00: Practically complete rewrite.
+*)
+*/
+%{
+open Cabs
+open Cabshelper
+open Parse_aux
+
+(*
+** Expression building
+*)
+let smooth_expression lst =
+ match lst with
+ [] -> NOTHING
+ | [expr] -> expr
+ | _ -> COMMA (lst)
+
+
+let currentFunctionName = ref "<outside any function>"
+
+let announceFunctionName ((n, decl, _, _):name) =
+ !add_identifier n;
+ (* Start a context that includes the parameter names and the whole body.
+ * Will pop when we finish parsing the function body *)
+ !push_context ();
+ (* Go through all the parameter names and mark them as identifiers *)
+ let rec findProto = function
+ PROTO (d, args, _) when isJUSTBASE d ->
+ List.iter (fun (_, (an, _, _, _)) -> !add_identifier an) args
+
+ | PROTO (d, _, _) -> findProto d
+ | PARENTYPE (_, d, _) -> findProto d
+ | PTR (_, d) -> findProto d
+ | ARRAY (d, _, _) -> findProto d
+ | _ -> parse_error "Cannot find the prototype in a function definition";
+ raise Parsing.Parse_error
+
+ and isJUSTBASE = function
+ JUSTBASE -> true
+ | PARENTYPE (_, d, _) -> isJUSTBASE d
+ | _ -> false
+ in
+ findProto decl;
+ currentFunctionName := n
+
+
+
+let applyPointer (ptspecs: attribute list list) (dt: decl_type)
+ : decl_type =
+ (* Outer specification first *)
+ let rec loop = function
+ [] -> dt
+ | attrs :: rest -> PTR(attrs, loop rest)
+ in
+ loop ptspecs
+
+let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : definition =
+ if isTypedef specs then begin
+ (* Tell the lexer about the new type names *)
+ List.iter (fun ((n, _, _, _), _) -> !add_type n) nl;
+ TYPEDEF ((specs, List.map (fun (n, _) -> n) nl), loc)
+ end else
+ if nl = [] then
+ ONLYTYPEDEF (specs, loc)
+ else begin
+ (* Tell the lexer about the new variable names *)
+ List.iter (fun ((n, _, _, _), _) -> !add_identifier n) nl;
+ DECDEF ((specs, nl), loc)
+ end
+
+
+let doFunctionDef (loc: cabsloc)
+ (lend: cabsloc)
+ (specs: spec_elem list)
+ (n: name)
+ (b: block) : definition =
+ let fname = (specs, n) in
+ FUNDEF (fname, b, loc, lend)
+
+
+let doOldParDecl (names: string list)
+ ((pardefs: name_group list), (isva: bool))
+ : single_name list * bool =
+ let findOneName n =
+ (* Search in pardefs for the definition for this parameter *)
+ let rec loopGroups = function
+ [] -> ([SpecType Tint], (n, JUSTBASE, [], cabslu))
+ | (specs, names) :: restgroups ->
+ let rec loopNames = function
+ [] -> loopGroups restgroups
+ | ((n',_, _, _) as sn) :: _ when n' = n -> (specs, sn)
+ | _ :: restnames -> loopNames restnames
+ in
+ loopNames names
+ in
+ loopGroups pardefs
+ in
+ let args = List.map findOneName names in
+ (args, isva)
+
+let int64_to_char value =
+ if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then
+ begin
+ let msg = Printf.sprintf "cparser:intlist_to_string: character 0x%Lx too big" value in
+ parse_error msg;
+ raise Parsing.Parse_error
+ end
+ else
+ Char.chr (Int64.to_int value)
+
+(* takes a not-nul-terminated list, and converts it to a string. *)
+let rec intlist_to_string (str: int64 list):string =
+ match str with
+ [] -> "" (* add nul-termination *)
+ | value::rest ->
+ let this_char = int64_to_char value in
+ (String.make 1 this_char) ^ (intlist_to_string rest)
+
+let fst3 (result, _, _) = result
+let snd3 (_, result, _) = result
+let trd3 (_, _, result) = result
+
+
+(*
+ transform: __builtin_offsetof(type, member)
+ into : (size_t) (&(type * ) 0)->member
+ *)
+
+let transformOffsetOf (speclist, dtype) member =
+ let rec addPointer = function
+ | JUSTBASE ->
+ PTR([], JUSTBASE)
+ | PARENTYPE (attrs1, dtype, attrs2) ->
+ PARENTYPE (attrs1, addPointer dtype, attrs2)
+ | ARRAY (dtype, attrs, expr) ->
+ ARRAY (addPointer dtype, attrs, expr)
+ | PTR (attrs, dtype) ->
+ PTR (attrs, addPointer dtype)
+ | PROTO (dtype, names, variadic) ->
+ PROTO (addPointer dtype, names, variadic)
+ in
+ let nullType = (speclist, addPointer dtype) in
+ let nullExpr = CONSTANT (CONST_INT "0") in
+ let castExpr = CAST (nullType, SINGLE_INIT nullExpr) in
+
+ let rec replaceBase = function
+ | VARIABLE field ->
+ MEMBEROFPTR (castExpr, field)
+ | MEMBEROF (base, field) ->
+ MEMBEROF (replaceBase base, field)
+ | INDEX (base, index) ->
+ INDEX (replaceBase base, index)
+ | _ ->
+ parse_error "malformed offset expression in __builtin_offsetof";
+ raise Parsing.Parse_error
+ in
+ let memberExpr = replaceBase member in
+ let addrExpr = UNARY (ADDROF, memberExpr) in
+ (* slight cheat: hard-coded assumption that size_t == unsigned int *)
+ let sizeofType = [SpecType Tunsigned], JUSTBASE in
+ let resultExpr = CAST (sizeofType, SINGLE_INIT addrExpr) in
+ resultExpr
+
+%}
+
+%token <string * Cabs.cabsloc> IDENT
+%token <int64 list * Cabs.cabsloc> CST_CHAR
+%token <int64 list * Cabs.cabsloc> CST_WCHAR
+%token <string * Cabs.cabsloc> CST_INT
+%token <string * Cabs.cabsloc> CST_FLOAT
+%token <string * Cabs.cabsloc> NAMED_TYPE
+
+/* Each character is its own list element, and the terminating nul is not
+ included in this list. */
+%token <int64 list * Cabs.cabsloc> CST_STRING
+%token <int64 list * Cabs.cabsloc> CST_WSTRING
+
+%token EOF
+%token<Cabs.cabsloc> CHAR INT DOUBLE FLOAT VOID INT64 INT32 UNDERSCORE_BOOL
+%token<Cabs.cabsloc> ENUM STRUCT TYPEDEF UNION
+%token<Cabs.cabsloc> SIGNED UNSIGNED LONG SHORT
+%token<Cabs.cabsloc> VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER
+%token<Cabs.cabsloc> THREAD
+
+%token<Cabs.cabsloc> SIZEOF ALIGNOF
+
+%token EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
+%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
+%token ARROW DOT
+
+%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ
+%token<Cabs.cabsloc> PLUS MINUS STAR
+%token SLASH PERCENT
+%token<Cabs.cabsloc> TILDE AND
+%token PIPE CIRC
+%token<Cabs.cabsloc> EXCLAM AND_AND
+%token PIPE_PIPE
+%token INF_INF SUP_SUP
+%token<Cabs.cabsloc> PLUS_PLUS MINUS_MINUS
+
+%token RPAREN
+%token<Cabs.cabsloc> LPAREN RBRACE
+%token<Cabs.cabsloc> LBRACE
+%token LBRACKET RBRACKET
+%token COLON
+%token<Cabs.cabsloc> SEMICOLON
+%token COMMA ELLIPSIS QUEST
+
+%token<Cabs.cabsloc> BREAK CONTINUE GOTO RETURN
+%token<Cabs.cabsloc> SWITCH CASE DEFAULT
+%token<Cabs.cabsloc> WHILE DO FOR
+%token<Cabs.cabsloc> IF TRY EXCEPT FINALLY
+%token ELSE
+
+%token<Cabs.cabsloc> ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__
+%token LABEL__
+%token<Cabs.cabsloc> BUILTIN_VA_ARG ATTRIBUTE_USED
+%token BUILTIN_VA_LIST
+%token BLOCKATTRIBUTE
+%token<Cabs.cabsloc> BUILTIN_TYPES_COMPAT BUILTIN_OFFSETOF
+%token<Cabs.cabsloc> DECLSPEC
+%token<string * Cabs.cabsloc> MSASM MSATTR
+%token<string * Cabs.cabsloc> PRAGMA_LINE
+%token PRAGMA_EOL
+
+/* operator precedence */
+%nonassoc IF
+%nonassoc ELSE
+
+
+%left COMMA
+%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ
+ AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ
+%right QUEST COLON
+%left PIPE_PIPE
+%left AND_AND
+%left PIPE
+%left CIRC
+%left AND
+%left EQ_EQ EXCLAM_EQ
+%left INF SUP INF_EQ SUP_EQ
+%left INF_INF SUP_SUP
+%left PLUS MINUS
+%left STAR SLASH PERCENT CONST RESTRICT VOLATILE
+%right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF
+%left LBRACKET
+%left DOT ARROW LPAREN LBRACE
+%right NAMED_TYPE /* We'll use this to handle redefinitions of
+ * NAMED_TYPE as variables */
+%left IDENT
+
+/* Non-terminals informations */
+%start interpret file
+%type <Cabs.definition list> file interpret globals
+
+%type <Cabs.definition> global
+
+
+%type <Cabs.attribute list> attributes attributes_with_asm asmattr
+%type <Cabs.statement> statement
+%type <Cabs.constant * cabsloc> constant
+%type <string * cabsloc> string_constant
+%type <Cabs.expression * cabsloc> expression
+%type <Cabs.expression> opt_expression
+%type <Cabs.init_expression> init_expression
+%type <Cabs.expression list * cabsloc> comma_expression
+%type <Cabs.expression list * cabsloc> paren_comma_expression
+%type <Cabs.expression list> arguments
+%type <Cabs.expression list> bracket_comma_expression
+%type <int64 list Queue.t * cabsloc> string_list
+%type <int64 list * cabsloc> wstring_list
+
+%type <Cabs.initwhat * Cabs.init_expression> initializer
+%type <(Cabs.initwhat * Cabs.init_expression) list> initializer_list
+%type <Cabs.initwhat> init_designators init_designators_opt
+
+%type <spec_elem list * cabsloc> decl_spec_list
+%type <typeSpecifier * cabsloc> type_spec
+%type <Cabs.field_group list> struct_decl_list
+
+
+%type <Cabs.name> old_proto_decl
+%type <Cabs.single_name> parameter_decl
+%type <Cabs.enum_item> enumerator
+%type <Cabs.enum_item list> enum_list
+%type <Cabs.definition> declaration function_def
+%type <cabsloc * spec_elem list * name> function_def_start
+%type <Cabs.spec_elem list * Cabs.decl_type> type_name
+%type <Cabs.block * cabsloc * cabsloc> block
+%type <Cabs.statement list> block_element_list
+%type <string list> local_labels local_label_names
+%type <string list> old_parameter_list_ne
+
+%type <Cabs.init_name> init_declarator
+%type <Cabs.init_name list> init_declarator_list
+%type <Cabs.name> declarator
+%type <Cabs.name * expression option> field_decl
+%type <(Cabs.name * expression option) list> field_decl_list
+%type <string * Cabs.decl_type> direct_decl
+%type <Cabs.decl_type> abs_direct_decl abs_direct_decl_opt
+%type <Cabs.decl_type * Cabs.attribute list> abstract_decl
+
+ /* (* Each element is a "* <type_quals_opt>". *) */
+%type <attribute list list * cabsloc> pointer pointer_opt
+%type <Cabs.cabsloc> location
+%type <Cabs.spec_elem * cabsloc> cvspec
+%%
+
+interpret:
+ file EOF {$1}
+;
+file: globals {$1}
+;
+globals:
+ /* empty */ { [] }
+| global globals { $1 :: $2 }
+| SEMICOLON globals { $2 }
+;
+
+location:
+ /* empty */ { currentLoc () } %prec IDENT
+
+
+/*** Global Definition ***/
+global:
+| declaration { $1 }
+| function_def { $1 }
+/*(* Some C header files ar shared with the C++ compiler and have linkage
+ * specification *)*/
+| EXTERN string_constant declaration { LINKAGE (fst $2, (*handleLoc*) (snd $2), [ $3 ]) }
+| EXTERN string_constant LBRACE globals RBRACE
+ { LINKAGE (fst $2, (*handleLoc*) (snd $2), $4) }
+| ASM LPAREN string_constant RPAREN SEMICOLON
+ { GLOBASM (fst $3, (*handleLoc*) $1) }
+| pragma { $1 }
+/* (* Old-style function prototype. This should be somewhere else, like in
+ * "declaration". For now we keep it at global scope only because in local
+ * scope it looks too much like a function call *) */
+| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON
+ { (* Convert pardecl to new style *)
+ let pardecl, isva = doOldParDecl $3 $5 in
+ (* Make the function declarator *)
+ doDeclaration ((*handleLoc*) (snd $1)) []
+ [((fst $1, PROTO(JUSTBASE, pardecl,isva), [], cabslu),
+ NO_INIT)]
+ }
+/* (* Old style function prototype, but without any arguments *) */
+| IDENT LPAREN RPAREN SEMICOLON
+ { (* Make the function declarator *)
+ doDeclaration ((*handleLoc*)(snd $1)) []
+ [((fst $1, PROTO(JUSTBASE,[],false), [], cabslu),
+ NO_INIT)]
+ }
+/* | location error SEMICOLON { PRAGMA (VARIABLE "parse_error", $1) } */
+;
+
+id_or_typename:
+ IDENT {fst $1}
+| NAMED_TYPE {fst $1}
+;
+
+maybecomma:
+ /* empty */ { () }
+| COMMA { () }
+;
+
+/* *** Expressions *** */
+
+primary_expression: /*(* 6.5.1. *)*/
+| IDENT
+ {VARIABLE (fst $1), snd $1}
+| constant
+ {CONSTANT (fst $1), snd $1}
+| paren_comma_expression
+ {PAREN (smooth_expression (fst $1)), snd $1}
+| LPAREN block RPAREN
+ { GNU_BODY (fst3 $2), $1 }
+;
+
+postfix_expression: /*(* 6.5.2 *)*/
+| primary_expression
+ { $1 }
+| postfix_expression bracket_comma_expression
+ {INDEX (fst $1, smooth_expression $2), snd $1}
+| postfix_expression LPAREN arguments RPAREN
+ {CALL (fst $1, $3), snd $1}
+| BUILTIN_VA_ARG LPAREN expression COMMA type_name RPAREN
+ { let b, d = $5 in
+ CALL (VARIABLE "__builtin_va_arg",
+ [fst $3; TYPE_SIZEOF (b, d)]), $1 }
+| BUILTIN_TYPES_COMPAT LPAREN type_name COMMA type_name RPAREN
+ { let b1,d1 = $3 in
+ let b2,d2 = $5 in
+ CALL (VARIABLE "__builtin_types_compatible_p",
+ [TYPE_SIZEOF(b1,d1); TYPE_SIZEOF(b2,d2)]), $1 }
+| BUILTIN_OFFSETOF LPAREN type_name COMMA offsetof_member_designator RPAREN
+ { transformOffsetOf $3 $5, $1 }
+| postfix_expression DOT id_or_typename
+ {MEMBEROF (fst $1, $3), snd $1}
+| postfix_expression ARROW id_or_typename
+ {MEMBEROFPTR (fst $1, $3), snd $1}
+| postfix_expression PLUS_PLUS
+ {UNARY (POSINCR, fst $1), snd $1}
+| postfix_expression MINUS_MINUS
+ {UNARY (POSDECR, fst $1), snd $1}
+/* (* We handle GCC constructor expressions *) */
+| LPAREN type_name RPAREN LBRACE initializer_list_opt RBRACE
+ { CAST($2, COMPOUND_INIT $5), $1 }
+;
+
+offsetof_member_designator: /* GCC extension for __builtin_offsetof */
+| id_or_typename
+ { VARIABLE ($1) }
+| offsetof_member_designator DOT IDENT
+ { MEMBEROF ($1, fst $3) }
+| offsetof_member_designator bracket_comma_expression
+ { INDEX ($1, smooth_expression $2) }
+;
+
+unary_expression: /*(* 6.5.3 *)*/
+| postfix_expression
+ { $1 }
+| PLUS_PLUS unary_expression
+ {UNARY (PREINCR, fst $2), $1}
+| MINUS_MINUS unary_expression
+ {UNARY (PREDECR, fst $2), $1}
+| SIZEOF unary_expression
+ {EXPR_SIZEOF (fst $2), $1}
+| SIZEOF LPAREN type_name RPAREN
+ {let b, d = $3 in TYPE_SIZEOF (b, d), $1}
+| ALIGNOF unary_expression
+ {EXPR_ALIGNOF (fst $2), $1}
+| ALIGNOF LPAREN type_name RPAREN
+ {let b, d = $3 in TYPE_ALIGNOF (b, d), $1}
+| PLUS cast_expression
+ {UNARY (PLUS, fst $2), $1}
+| MINUS cast_expression
+ {UNARY (MINUS, fst $2), $1}
+| STAR cast_expression
+ {UNARY (MEMOF, fst $2), $1}
+| AND cast_expression
+ {UNARY (ADDROF, fst $2), $1}
+| EXCLAM cast_expression
+ {UNARY (NOT, fst $2), $1}
+| TILDE cast_expression
+ {UNARY (BNOT, fst $2), $1}
+| AND_AND IDENT { LABELADDR (fst $2), $1 }
+;
+
+cast_expression: /*(* 6.5.4 *)*/
+| unary_expression
+ { $1 }
+| LPAREN type_name RPAREN cast_expression
+ { CAST($2, SINGLE_INIT (fst $4)), $1 }
+;
+
+multiplicative_expression: /*(* 6.5.5 *)*/
+| cast_expression
+ { $1 }
+| multiplicative_expression STAR cast_expression
+ {BINARY(MUL, fst $1, fst $3), snd $1}
+| multiplicative_expression SLASH cast_expression
+ {BINARY(DIV, fst $1, fst $3), snd $1}
+| multiplicative_expression PERCENT cast_expression
+ {BINARY(MOD, fst $1, fst $3), snd $1}
+;
+
+additive_expression: /*(* 6.5.6 *)*/
+| multiplicative_expression
+ { $1 }
+| additive_expression PLUS multiplicative_expression
+ {BINARY(ADD, fst $1, fst $3), snd $1}
+| additive_expression MINUS multiplicative_expression
+ {BINARY(SUB, fst $1, fst $3), snd $1}
+;
+
+shift_expression: /*(* 6.5.7 *)*/
+| additive_expression
+ { $1 }
+| shift_expression INF_INF additive_expression
+ {BINARY(SHL, fst $1, fst $3), snd $1}
+| shift_expression SUP_SUP additive_expression
+ {BINARY(SHR, fst $1, fst $3), snd $1}
+;
+
+
+relational_expression: /*(* 6.5.8 *)*/
+| shift_expression
+ { $1 }
+| relational_expression INF shift_expression
+ {BINARY(LT, fst $1, fst $3), snd $1}
+| relational_expression SUP shift_expression
+ {BINARY(GT, fst $1, fst $3), snd $1}
+| relational_expression INF_EQ shift_expression
+ {BINARY(LE, fst $1, fst $3), snd $1}
+| relational_expression SUP_EQ shift_expression
+ {BINARY(GE, fst $1, fst $3), snd $1}
+;
+
+equality_expression: /*(* 6.5.9 *)*/
+| relational_expression
+ { $1 }
+| equality_expression EQ_EQ relational_expression
+ {BINARY(EQ, fst $1, fst $3), snd $1}
+| equality_expression EXCLAM_EQ relational_expression
+ {BINARY(NE, fst $1, fst $3), snd $1}
+;
+
+
+bitwise_and_expression: /*(* 6.5.10 *)*/
+| equality_expression
+ { $1 }
+| bitwise_and_expression AND equality_expression
+ {BINARY(BAND, fst $1, fst $3), snd $1}
+;
+
+bitwise_xor_expression: /*(* 6.5.11 *)*/
+| bitwise_and_expression
+ { $1 }
+| bitwise_xor_expression CIRC bitwise_and_expression
+ {BINARY(XOR, fst $1, fst $3), snd $1}
+;
+
+bitwise_or_expression: /*(* 6.5.12 *)*/
+| bitwise_xor_expression
+ { $1 }
+| bitwise_or_expression PIPE bitwise_xor_expression
+ {BINARY(BOR, fst $1, fst $3), snd $1}
+;
+
+logical_and_expression: /*(* 6.5.13 *)*/
+| bitwise_or_expression
+ { $1 }
+| logical_and_expression AND_AND bitwise_or_expression
+ {BINARY(AND, fst $1, fst $3), snd $1}
+;
+
+logical_or_expression: /*(* 6.5.14 *)*/
+| logical_and_expression
+ { $1 }
+| logical_or_expression PIPE_PIPE logical_and_expression
+ {BINARY(OR, fst $1, fst $3), snd $1}
+;
+
+conditional_expression: /*(* 6.5.15 *)*/
+| logical_or_expression
+ { $1 }
+| logical_or_expression QUEST opt_expression COLON conditional_expression
+ {QUESTION (fst $1, $3, fst $5), snd $1}
+;
+
+/*(* The C spec says that left-hand sides of assignment expressions are unary
+ * expressions. GCC allows cast expressions in there ! *)*/
+
+assignment_expression: /*(* 6.5.16 *)*/
+| conditional_expression
+ { $1 }
+| cast_expression EQ assignment_expression
+ {BINARY(ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression PLUS_EQ assignment_expression
+ {BINARY(ADD_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression MINUS_EQ assignment_expression
+ {BINARY(SUB_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression STAR_EQ assignment_expression
+ {BINARY(MUL_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression SLASH_EQ assignment_expression
+ {BINARY(DIV_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression PERCENT_EQ assignment_expression
+ {BINARY(MOD_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression AND_EQ assignment_expression
+ {BINARY(BAND_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression PIPE_EQ assignment_expression
+ {BINARY(BOR_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression CIRC_EQ assignment_expression
+ {BINARY(XOR_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression INF_INF_EQ assignment_expression
+ {BINARY(SHL_ASSIGN, fst $1, fst $3), snd $1}
+| cast_expression SUP_SUP_EQ assignment_expression
+ {BINARY(SHR_ASSIGN, fst $1, fst $3), snd $1}
+;
+
+expression: /*(* 6.5.17 *)*/
+ assignment_expression
+ { $1 }
+;
+
+
+constant:
+ CST_INT {CONST_INT (fst $1), snd $1}
+| CST_FLOAT {CONST_FLOAT (fst $1), snd $1}
+| CST_CHAR {CONST_CHAR (fst $1), snd $1}
+| CST_WCHAR {CONST_WCHAR (fst $1), snd $1}
+| string_constant {CONST_STRING (fst $1), snd $1}
+| wstring_list {CONST_WSTRING (fst $1), snd $1}
+;
+
+string_constant:
+/* Now that we know this constant isn't part of a wstring, convert it
+ back to a string for easy viewing. */
+ string_list {
+ let queue, location = $1 in
+ let buffer = Buffer.create (Queue.length queue) in
+ Queue.iter
+ (List.iter
+ (fun value ->
+ let char = int64_to_char value in
+ Buffer.add_char buffer char))
+ queue;
+ Buffer.contents buffer, location
+ }
+;
+one_string_constant:
+/* Don't concat multiple strings. For asm templates. */
+ CST_STRING {intlist_to_string (fst $1) }
+;
+string_list:
+ one_string {
+ let queue = Queue.create () in
+ Queue.add (fst $1) queue;
+ queue, snd $1
+ }
+| string_list one_string {
+ Queue.add (fst $2) (fst $1);
+ $1
+ }
+;
+
+wstring_list:
+ CST_WSTRING { $1 }
+| wstring_list one_string { (fst $1) @ (fst $2), snd $1 }
+| wstring_list CST_WSTRING { (fst $1) @ (fst $2), snd $1 }
+/* Only the first string in the list needs an L, so L"a" "b" is the same
+ * as L"ab" or L"a" L"b". */
+
+one_string:
+ CST_STRING {$1}
+| FUNCTION__ {(Cabshelper.explodeStringToInts
+ !currentFunctionName), $1}
+| PRETTY_FUNCTION__ {(Cabshelper.explodeStringToInts
+ !currentFunctionName), $1}
+;
+
+init_expression:
+ expression { SINGLE_INIT (fst $1) }
+| LBRACE initializer_list_opt RBRACE
+ { COMPOUND_INIT $2}
+
+initializer_list: /* ISO 6.7.8. Allow a trailing COMMA */
+ initializer { [$1] }
+| initializer COMMA initializer_list_opt { $1 :: $3 }
+;
+initializer_list_opt:
+ /* empty */ { [] }
+| initializer_list { $1 }
+;
+initializer:
+ init_designators eq_opt init_expression { ($1, $3) }
+| gcc_init_designators init_expression { ($1, $2) }
+| init_expression { (NEXT_INIT, $1) }
+;
+eq_opt:
+ EQ { () }
+ /*(* GCC allows missing = *)*/
+| /*(* empty *)*/ { () }
+;
+init_designators:
+ DOT id_or_typename init_designators_opt { INFIELD_INIT($2, $3) }
+| LBRACKET expression RBRACKET init_designators_opt
+ { ATINDEX_INIT(fst $2, $4) }
+| LBRACKET expression ELLIPSIS expression RBRACKET
+ { ATINDEXRANGE_INIT(fst $2, fst $4) }
+;
+init_designators_opt:
+ /* empty */ { NEXT_INIT }
+| init_designators { $1 }
+;
+
+gcc_init_designators: /*(* GCC supports these strange things *)*/
+ id_or_typename COLON { INFIELD_INIT($1, NEXT_INIT) }
+;
+
+arguments:
+ /* empty */ { [] }
+| comma_expression { fst $1 }
+;
+
+opt_expression:
+ /* empty */
+ {NOTHING}
+| comma_expression
+ {smooth_expression (fst $1)}
+;
+
+comma_expression:
+ expression {[fst $1], snd $1}
+| expression COMMA comma_expression { fst $1 :: fst $3, snd $1 }
+| error COMMA comma_expression { $3 }
+;
+
+comma_expression_opt:
+ /* empty */ { NOTHING }
+| comma_expression { smooth_expression (fst $1) }
+;
+
+paren_comma_expression:
+ LPAREN comma_expression RPAREN { $2 }
+| LPAREN error RPAREN { [], $1 }
+;
+
+bracket_comma_expression:
+ LBRACKET comma_expression RBRACKET { fst $2 }
+| LBRACKET error RBRACKET { [] }
+;
+
+
+/*** statements ***/
+block: /* ISO 6.8.2 */
+ block_begin local_labels block_attrs block_element_list RBRACE
+ {!pop_context();
+ { blabels = $2;
+ battrs = $3;
+ bstmts = $4 },
+ $1, $5
+ }
+| error location RBRACE { { blabels = [];
+ battrs = [];
+ bstmts = [] },
+ $2, $3
+ }
+;
+block_begin:
+ LBRACE {!push_context (); $1}
+;
+
+block_attrs:
+ /* empty */ { [] }
+| BLOCKATTRIBUTE paren_attr_list_ne
+ { [("__blockattribute__", $2)] }
+;
+
+/* statements and declarations in a block, in any order (for C99 support) */
+block_element_list:
+ /* empty */ { [] }
+| declaration block_element_list { DEFINITION($1) :: $2 }
+| statement block_element_list { $1 :: $2 }
+/*(* GCC accepts a label at the end of a block *)*/
+| IDENT COLON { [ LABEL (fst $1, NOP (snd $1),
+ snd $1)] }
+| pragma block_element_list { $2 }
+;
+
+local_labels:
+ /* empty */ { [] }
+| LABEL__ local_label_names SEMICOLON local_labels { $2 @ $4 }
+;
+local_label_names:
+ IDENT { [ fst $1 ] }
+| IDENT COMMA local_label_names { fst $1 :: $3 }
+;
+
+
+
+statement:
+ SEMICOLON {NOP ((*handleLoc*) $1) }
+| comma_expression SEMICOLON
+ {COMPUTATION (smooth_expression (fst $1), (*handleLoc*)(snd $1))}
+| block {BLOCK (fst3 $1, (*handleLoc*)(snd3 $1))}
+| IF paren_comma_expression statement %prec IF
+ {IF (smooth_expression (fst $2), $3, NOP $1, $1)}
+| IF paren_comma_expression statement ELSE statement
+ {IF (smooth_expression (fst $2), $3, $5, (*handleLoc*) $1)}
+| SWITCH paren_comma_expression statement
+ {SWITCH (smooth_expression (fst $2), $3, (*handleLoc*) $1)}
+| WHILE paren_comma_expression statement
+ {WHILE (smooth_expression (fst $2), $3, (*handleLoc*) $1)}
+| DO statement WHILE paren_comma_expression SEMICOLON
+ {DOWHILE (smooth_expression (fst $4), $2, (*handleLoc*) $1)}
+| FOR LPAREN for_clause opt_expression
+ SEMICOLON opt_expression RPAREN statement
+ {FOR ($3, $4, $6, $8, (*handleLoc*) $1)}
+| IDENT COLON attribute_nocv_list statement
+ {(* The only attribute that should appear here
+ is "unused". For now, we drop this on the
+ floor, since unused labels are usually
+ removed anyways by Rmtmps. *)
+ LABEL (fst $1, $4, (snd $1))}
+| CASE expression COLON statement
+ {CASE (fst $2, $4, (*handleLoc*) $1)}
+| CASE expression ELLIPSIS expression COLON statement
+ {CASERANGE (fst $2, fst $4, $6, (*handleLoc*) $1)}
+| DEFAULT COLON
+ {DEFAULT (NOP $1, (*handleLoc*) $1)}
+| RETURN SEMICOLON {RETURN (NOTHING, (*handleLoc*) $1)}
+| RETURN comma_expression SEMICOLON
+ {RETURN (smooth_expression (fst $2), (*handleLoc*) $1)}
+| BREAK SEMICOLON {BREAK ((*handleLoc*) $1)}
+| CONTINUE SEMICOLON {CONTINUE ((*handleLoc*) $1)}
+| GOTO IDENT SEMICOLON
+ {GOTO (fst $2, (*handleLoc*) $1)}
+| GOTO STAR comma_expression SEMICOLON
+ { COMPGOTO (smooth_expression (fst $3), (*handleLoc*) $1) }
+| ASM asmattr LPAREN asmtemplate asmoutputs RPAREN SEMICOLON
+ { ASM ($2, $4, $5, (*handleLoc*) $1) }
+| MSASM { ASM ([], [fst $1], None, (*handleLoc*)(snd $1))}
+| TRY block EXCEPT paren_comma_expression block
+ { let b, _, _ = $2 in
+ let h, _, _ = $5 in
+ if not !msvcMode then
+ parse_error "try/except in GCC code";
+ TRY_EXCEPT (b, COMMA (fst $4), h, (*handleLoc*) $1) }
+| TRY block FINALLY block
+ { let b, _, _ = $2 in
+ let h, _, _ = $4 in
+ if not !msvcMode then
+ parse_error "try/finally in GCC code";
+ TRY_FINALLY (b, h, (*handleLoc*) $1) }
+
+| error location SEMICOLON { (NOP $2)}
+;
+
+
+for_clause:
+ opt_expression SEMICOLON { FC_EXP $1 }
+| declaration { FC_DECL $1 }
+;
+
+declaration: /* ISO 6.7.*/
+ decl_spec_list init_declarator_list SEMICOLON
+ { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) $2 }
+| decl_spec_list SEMICOLON
+ { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) [] }
+;
+init_declarator_list: /* ISO 6.7 */
+ init_declarator { [$1] }
+| init_declarator COMMA init_declarator_list { $1 :: $3 }
+
+;
+init_declarator: /* ISO 6.7 */
+ declarator { ($1, NO_INIT) }
+| declarator EQ init_expression
+ { ($1, $3) }
+;
+
+decl_spec_list: /* ISO 6.7 */
+ /* ISO 6.7.1 */
+| TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 }
+| EXTERN decl_spec_list_opt { SpecStorage EXTERN :: $2, $1 }
+| STATIC decl_spec_list_opt { SpecStorage STATIC :: $2, $1 }
+| AUTO decl_spec_list_opt { SpecStorage AUTO :: $2, $1 }
+| REGISTER decl_spec_list_opt { SpecStorage REGISTER :: $2, $1}
+ /* ISO 6.7.2 */
+| type_spec decl_spec_list_opt_no_named { SpecType (fst $1) :: $2, snd $1 }
+ /* ISO 6.7.4 */
+| INLINE decl_spec_list_opt { SpecInline :: $2, $1 }
+| cvspec decl_spec_list_opt { (fst $1) :: $2, snd $1 }
+| attribute_nocv decl_spec_list_opt { SpecAttr (fst $1) :: $2, snd $1 }
+;
+/* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare
+ * NAMED_TYPE to have right associativity *) */
+decl_spec_list_opt:
+ /* empty */ { [] } %prec NAMED_TYPE
+| decl_spec_list { fst $1 }
+;
+/* (* We add this separate rule to handle the special case when an appearance
+ * of NAMED_TYPE should not be considered as part of the specifiers but as
+ * part of the declarator. IDENT has higher precedence than NAMED_TYPE *)
+ */
+decl_spec_list_opt_no_named:
+ /* empty */ { [] } %prec IDENT
+| decl_spec_list { fst $1 }
+;
+type_spec: /* ISO 6.7.2 */
+ VOID { Tvoid, $1}
+| UNDERSCORE_BOOL { T_Bool, $1 }
+| CHAR { Tchar, $1 }
+| SHORT { Tshort, $1 }
+| INT { Tint, $1 }
+| LONG { Tlong, $1 }
+| INT64 { Tint64, $1 }
+| FLOAT { Tfloat, $1 }
+| DOUBLE { Tdouble, $1 }
+| SIGNED { Tsigned, $1 }
+| UNSIGNED { Tunsigned, $1 }
+| STRUCT id_or_typename
+ { Tstruct ($2, None, []), $1 }
+| STRUCT just_attributes id_or_typename
+ { Tstruct ($3, None, $2), $1 }
+| STRUCT id_or_typename LBRACE struct_decl_list RBRACE
+ { Tstruct ($2, Some $4, []), $1 }
+| STRUCT LBRACE struct_decl_list RBRACE
+ { Tstruct ("", Some $3, []), $1 }
+| STRUCT just_attributes id_or_typename LBRACE struct_decl_list RBRACE
+ { Tstruct ($3, Some $5, $2), $1 }
+| STRUCT just_attributes LBRACE struct_decl_list RBRACE
+ { Tstruct ("", Some $4, $2), $1 }
+| UNION id_or_typename
+ { Tunion ($2, None, []), $1 }
+| UNION id_or_typename LBRACE struct_decl_list RBRACE
+ { Tunion ($2, Some $4, []), $1 }
+| UNION LBRACE struct_decl_list RBRACE
+ { Tunion ("", Some $3, []), $1 }
+| UNION just_attributes id_or_typename LBRACE struct_decl_list RBRACE
+ { Tunion ($3, Some $5, $2), $1 }
+| UNION just_attributes LBRACE struct_decl_list RBRACE
+ { Tunion ("", Some $4, $2), $1 }
+| ENUM id_or_typename
+ { Tenum ($2, None, []), $1 }
+| ENUM id_or_typename LBRACE enum_list maybecomma RBRACE
+ { Tenum ($2, Some $4, []), $1 }
+| ENUM LBRACE enum_list maybecomma RBRACE
+ { Tenum ("", Some $3, []), $1 }
+| ENUM just_attributes id_or_typename LBRACE enum_list maybecomma RBRACE
+ { Tenum ($3, Some $5, $2), $1 }
+| ENUM just_attributes LBRACE enum_list maybecomma RBRACE
+ { Tenum ("", Some $4, $2), $1 }
+| NAMED_TYPE { Tnamed (fst $1), snd $1 }
+| TYPEOF LPAREN expression RPAREN { TtypeofE (fst $3), $1 }
+| TYPEOF LPAREN type_name RPAREN { let s, d = $3 in
+ TtypeofT (s, d), $1 }
+;
+struct_decl_list: /* (* ISO 6.7.2. Except that we allow empty structs. We
+ * also allow missing field names. *)
+ */
+ /* empty */ { [] }
+| decl_spec_list SEMICOLON struct_decl_list
+ { (fst $1,
+ [(missingFieldDecl, None)]) :: $3 }
+/*(* GCC allows extra semicolons *)*/
+| SEMICOLON struct_decl_list
+ { $2 }
+| decl_spec_list field_decl_list SEMICOLON struct_decl_list
+ { (fst $1, $2)
+ :: $4 }
+/*(* MSVC allows pragmas in strange places *)*/
+| pragma struct_decl_list { $2 }
+
+| error SEMICOLON struct_decl_list
+ { $3 }
+;
+field_decl_list: /* (* ISO 6.7.2 *) */
+ field_decl { [$1] }
+| field_decl COMMA field_decl_list { $1 :: $3 }
+;
+field_decl: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */
+| declarator { ($1, None) }
+| declarator COLON expression attributes
+ { let (n,decl,al,loc) = $1 in
+ let al' = al @ $4 in
+ ((n,decl,al',loc), Some (fst $3)) }
+| COLON expression { (missingFieldDecl, Some (fst $2)) }
+;
+
+enum_list: /* (* ISO 6.7.2.2 *) */
+ enumerator {[$1]}
+| enum_list COMMA enumerator {$1 @ [$3]}
+| enum_list COMMA error { $1 }
+;
+enumerator:
+ IDENT {(fst $1, NOTHING, snd $1)}
+| IDENT EQ expression {(fst $1, fst $3, snd $1)}
+;
+
+
+declarator: /* (* ISO 6.7.5. Plus Microsoft declarators.*) */
+ pointer_opt direct_decl attributes_with_asm
+ { let (n, decl) = $2 in
+ (n, applyPointer (fst $1) decl, $3, (snd $1)) }
+;
+
+
+direct_decl: /* (* ISO 6.7.5 *) */
+ /* (* We want to be able to redefine named
+ * types as variable names *) */
+| id_or_typename { ($1, JUSTBASE) }
+
+| LPAREN attributes declarator RPAREN
+ { let (n,decl,al,loc) = $3 in
+ (n, PARENTYPE($2,decl,al)) }
+
+| direct_decl LBRACKET attributes comma_expression_opt RBRACKET
+ { let (n, decl) = $1 in
+ (n, ARRAY(decl, $3, $4)) }
+| direct_decl LBRACKET attributes error RBRACKET
+ { let (n, decl) = $1 in
+ (n, ARRAY(decl, $3, NOTHING)) }
+| direct_decl parameter_list_startscope rest_par_list RPAREN
+ { let (n, decl) = $1 in
+ let (params, isva) = $3 in
+ !pop_context ();
+ (n, PROTO(decl, params, isva))
+ }
+;
+parameter_list_startscope:
+ LPAREN { !push_context () }
+;
+rest_par_list:
+| /* empty */ { ([], false) }
+| parameter_decl rest_par_list1 { let (params, isva) = $2 in
+ ($1 :: params, isva)
+ }
+;
+rest_par_list1:
+ /* empty */ { ([], false) }
+| COMMA ELLIPSIS { ([], true) }
+| COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in
+ ($2 :: params, isva)
+ }
+;
+
+
+parameter_decl: /* (* ISO 6.7.5 *) */
+ decl_spec_list declarator { (fst $1, $2) }
+| decl_spec_list abstract_decl { let d, a = $2 in
+ (fst $1, ("", d, a, cabslu)) }
+| decl_spec_list { (fst $1, ("", JUSTBASE, [], cabslu)) }
+| LPAREN parameter_decl RPAREN { $2 }
+;
+
+/* (* Old style prototypes. Like a declarator *) */
+old_proto_decl:
+ pointer_opt direct_old_proto_decl { let (n, decl, a) = $2 in
+ (n, applyPointer (fst $1) decl,
+ a, snd $1)
+ }
+
+;
+
+direct_old_proto_decl:
+ direct_decl LPAREN old_parameter_list_ne RPAREN old_pardef_list
+ { let par_decl, isva = doOldParDecl $3 $5 in
+ let n, decl = $1 in
+ (n, PROTO(decl, par_decl, isva), [])
+ }
+| direct_decl LPAREN RPAREN
+ { let n, decl = $1 in
+ (n, PROTO(decl, [], false), [])
+ }
+
+/* (* appears sometimesm but generates a shift-reduce conflict. *)
+| LPAREN STAR direct_decl LPAREN old_parameter_list_ne RPAREN RPAREN LPAREN RPAREN old_pardef_list
+ { let par_decl, isva
+ = doOldParDecl $5 $10 in
+ let n, decl = $3 in
+ (n, PROTO(decl, par_decl, isva), [])
+ }
+*/
+;
+
+old_parameter_list_ne:
+| IDENT { [fst $1] }
+| IDENT COMMA old_parameter_list_ne { let rest = $3 in
+ (fst $1 :: rest) }
+;
+
+old_pardef_list:
+ /* empty */ { ([], false) }
+| decl_spec_list old_pardef SEMICOLON ELLIPSIS
+ { ([(fst $1, $2)], true) }
+| decl_spec_list old_pardef SEMICOLON old_pardef_list
+ { let rest, isva = $4 in
+ ((fst $1, $2) :: rest, isva)
+ }
+;
+
+old_pardef:
+ declarator { [$1] }
+| declarator COMMA old_pardef { $1 :: $3 }
+| error { [] }
+;
+
+
+pointer: /* (* ISO 6.7.5 *) */
+ STAR attributes pointer_opt { $2 :: fst $3, $1 }
+;
+pointer_opt:
+ /**/ { let l = currentLoc () in
+ ([], l) }
+| pointer { $1 }
+;
+
+type_name: /* (* ISO 6.7.6 *) */
+ decl_spec_list abstract_decl { let d, a = $2 in
+ if a <> [] then begin
+ parse_error "attributes in type name";
+ raise Parsing.Parse_error
+ end;
+ (fst $1, d)
+ }
+| decl_spec_list { (fst $1, JUSTBASE) }
+;
+abstract_decl: /* (* ISO 6.7.6. *) */
+ pointer_opt abs_direct_decl attributes { applyPointer (fst $1) $2, $3 }
+| pointer { applyPointer (fst $1) JUSTBASE, [] }
+;
+
+abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for
+ * functions. Plus Microsoft attributes. See the
+ * discussion for declarator. *) */
+| LPAREN attributes abstract_decl RPAREN
+ { let d, a = $3 in
+ PARENTYPE ($2, d, a)
+ }
+
+| LPAREN error RPAREN
+ { JUSTBASE }
+
+| abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET
+ { ARRAY($1, [], $3) }
+/*(* The next should be abs_direct_decl_opt but we get conflicts *)*/
+| abs_direct_decl parameter_list_startscope rest_par_list RPAREN
+ { let (params, isva) = $3 in
+ !pop_context ();
+ PROTO ($1, params, isva)
+ }
+;
+abs_direct_decl_opt:
+ abs_direct_decl { $1 }
+| /* empty */ { JUSTBASE }
+;
+function_def: /* (* ISO 6.9.1 *) */
+ function_def_start block
+ { let (loc, specs, decl) = $1 in
+ currentFunctionName := "<__FUNCTION__ used outside any functions>";
+ !pop_context (); (* The context pushed by
+ * announceFunctionName *)
+ doFunctionDef ((*handleLoc*) loc) (trd3 $2) specs decl (fst3 $2)
+ }
+
+
+function_def_start: /* (* ISO 6.9.1 *) */
+ decl_spec_list declarator
+ { announceFunctionName $2;
+ (snd $1, fst $1, $2)
+ }
+
+/* (* Old-style function prototype *) */
+| decl_spec_list old_proto_decl
+ { announceFunctionName $2;
+ (snd $1, fst $1, $2)
+ }
+/* (* New-style function that does not have a return type *) */
+| IDENT parameter_list_startscope rest_par_list RPAREN
+ { let (params, isva) = $3 in
+ let fdec =
+ (fst $1, PROTO(JUSTBASE, params, isva), [], snd $1) in
+ announceFunctionName fdec;
+ (* Default is int type *)
+ let defSpec = [SpecType Tint] in
+ (snd $1, defSpec, fdec)
+ }
+
+/* (* No return type and old-style parameter list *) */
+| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list
+ { (* Convert pardecl to new style *)
+ let pardecl, isva = doOldParDecl $3 $5 in
+ (* Make the function declarator *)
+ let fdec = (fst $1,
+ PROTO(JUSTBASE, pardecl,isva),
+ [], snd $1) in
+ announceFunctionName fdec;
+ (* Default is int type *)
+ let defSpec = [SpecType Tint] in
+ (snd $1, defSpec, fdec)
+ }
+/* (* No return type and no parameters *) */
+| IDENT LPAREN RPAREN
+ { (* Make the function declarator *)
+ let fdec = (fst $1,
+ PROTO(JUSTBASE, [], false),
+ [], snd $1) in
+ announceFunctionName fdec;
+ (* Default is int type *)
+ let defSpec = [SpecType Tint] in
+ (snd $1, defSpec, fdec)
+ }
+;
+
+/* const/volatile as type specifier elements */
+cvspec:
+ CONST { SpecCV(CV_CONST), $1 }
+| VOLATILE { SpecCV(CV_VOLATILE), $1 }
+| RESTRICT { SpecCV(CV_RESTRICT), $1 }
+;
+
+/*** GCC attributes ***/
+attributes:
+ /* empty */ { []}
+| attribute attributes { fst $1 :: $2 }
+;
+
+/* (* In some contexts we can have an inline assembly to specify the name to
+ * be used for a global. We treat this as a name attribute *) */
+attributes_with_asm:
+ /* empty */ { [] }
+| attribute attributes_with_asm { fst $1 :: $2 }
+| ASM LPAREN string_constant RPAREN attributes
+ { ("__asm__",
+ [CONSTANT(CONST_STRING (fst $3))]) :: $5 }
+;
+
+/* things like __attribute__, but no const/volatile */
+attribute_nocv:
+ ATTRIBUTE LPAREN paren_attr_list RPAREN
+ { ("__attribute__", $3), $1 }
+/*(*
+| ATTRIBUTE_USED { ("__attribute__",
+ [ VARIABLE "used" ]), $1 }
+*)*/
+| DECLSPEC paren_attr_list_ne { ("__declspec", $2), $1 }
+| MSATTR { (fst $1, []), snd $1 }
+ /* ISO 6.7.3 */
+| THREAD { ("__thread",[]), $1 }
+;
+
+attribute_nocv_list:
+ /* empty */ { []}
+| attribute_nocv attribute_nocv_list { fst $1 :: $2 }
+;
+
+/* __attribute__ plus const/volatile */
+attribute:
+ attribute_nocv { $1 }
+| CONST { ("const", []), $1 }
+| RESTRICT { ("restrict",[]), $1 }
+| VOLATILE { ("volatile",[]), $1 }
+;
+
+/* (* sm: I need something that just includes __attribute__ and nothing more,
+ * to support them appearing between the 'struct' keyword and the type name.
+ * Actually, a declspec can appear there as well (on MSVC) *) */
+just_attribute:
+ ATTRIBUTE LPAREN paren_attr_list RPAREN
+ { ("__attribute__", $3) }
+| DECLSPEC paren_attr_list_ne { ("__declspec", $2) }
+;
+
+/* this can't be empty, b/c I folded that possibility into the calling
+ * productions to avoid some S/R conflicts */
+just_attributes:
+ just_attribute { [$1] }
+| just_attribute just_attributes { $1 :: $2 }
+;
+
+/** (* PRAGMAS and ATTRIBUTES *) ***/
+pragma:
+| PRAGMA_LINE { PRAGMA (fst $1, snd $1) }
+;
+
+/* (* We want to allow certain strange things that occur in pragmas, so we
+ * cannot use directly the language of expressions *) */
+primary_attr:
+ IDENT { VARIABLE (fst $1) }
+ /*(* The NAMED_TYPE here creates conflicts with IDENT *)*/
+| NAMED_TYPE { VARIABLE (fst $1) }
+| LPAREN attr RPAREN { $2 }
+| IDENT IDENT { CALL(VARIABLE (fst $1), [VARIABLE (fst $2)]) }
+| CST_INT { CONSTANT(CONST_INT (fst $1)) }
+| string_constant { CONSTANT(CONST_STRING (fst $1)) }
+ /*(* Const when it appears in
+ * attribute lists, is translated
+ * to aconst *)*/
+| CONST { VARIABLE "aconst" }
+
+| IDENT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) }
+
+/*(* The following rule conflicts with the ? : attributes. We give it a very
+ * low priority *)*/
+| CST_INT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) }
+
+| DEFAULT COLON CST_INT { VARIABLE ("default:" ^ fst $3) }
+
+ /*(** GCC allows this as an
+ * attribute for functions,
+ * synonim for noreturn **)*/
+| VOLATILE { VARIABLE ("__noreturn__") }
+;
+
+postfix_attr:
+ primary_attr { $1 }
+ /* (* use a VARIABLE "" so that the
+ * parentheses are printed *) */
+| IDENT LPAREN RPAREN { CALL(VARIABLE (fst $1), [VARIABLE ""]) }
+| IDENT paren_attr_list_ne { CALL(VARIABLE (fst $1), $2) }
+
+| postfix_attr ARROW id_or_typename {MEMBEROFPTR ($1, $3)}
+| postfix_attr DOT id_or_typename {MEMBEROF ($1, $3)}
+| postfix_attr LBRACKET attr RBRACKET {INDEX ($1, $3) }
+;
+
+/*(* Since in attributes we use both IDENT and NAMED_TYPE as indentifiers,
+ * that leads to conflicts for SIZEOF and ALIGNOF. In those cases we require
+ * that their arguments be expressions, not attributes *)*/
+unary_attr:
+ postfix_attr { $1 }
+| SIZEOF unary_expression {EXPR_SIZEOF (fst $2) }
+| SIZEOF LPAREN type_name RPAREN
+ {let b, d = $3 in TYPE_SIZEOF (b, d)}
+
+| ALIGNOF unary_expression {EXPR_ALIGNOF (fst $2) }
+| ALIGNOF LPAREN type_name RPAREN {let b, d = $3 in TYPE_ALIGNOF (b, d)}
+| PLUS cast_attr {UNARY (PLUS, $2)}
+| MINUS cast_attr {UNARY (MINUS, $2)}
+| STAR cast_attr {UNARY (MEMOF, $2)}
+| AND cast_attr
+ {UNARY (ADDROF, $2)}
+| EXCLAM cast_attr {UNARY (NOT, $2)}
+| TILDE cast_attr {UNARY (BNOT, $2)}
+;
+
+cast_attr:
+ unary_attr { $1 }
+;
+
+multiplicative_attr:
+ cast_attr { $1 }
+| multiplicative_attr STAR cast_attr {BINARY(MUL ,$1 , $3)}
+| multiplicative_attr SLASH cast_attr {BINARY(DIV ,$1 , $3)}
+| multiplicative_attr PERCENT cast_attr {BINARY(MOD ,$1 , $3)}
+;
+
+
+additive_attr:
+ multiplicative_attr { $1 }
+| additive_attr PLUS multiplicative_attr {BINARY(ADD ,$1 , $3)}
+| additive_attr MINUS multiplicative_attr {BINARY(SUB ,$1 , $3)}
+;
+
+shift_attr:
+ additive_attr { $1 }
+| shift_attr INF_INF additive_attr {BINARY(SHL ,$1 , $3)}
+| shift_attr SUP_SUP additive_attr {BINARY(SHR ,$1 , $3)}
+;
+
+relational_attr:
+ shift_attr { $1 }
+| relational_attr INF shift_attr {BINARY(LT ,$1 , $3)}
+| relational_attr SUP shift_attr {BINARY(GT ,$1 , $3)}
+| relational_attr INF_EQ shift_attr {BINARY(LE ,$1 , $3)}
+| relational_attr SUP_EQ shift_attr {BINARY(GE ,$1 , $3)}
+;
+
+equality_attr:
+ relational_attr { $1 }
+| equality_attr EQ_EQ relational_attr {BINARY(EQ ,$1 , $3)}
+| equality_attr EXCLAM_EQ relational_attr {BINARY(NE ,$1 , $3)}
+;
+
+
+bitwise_and_attr:
+ equality_attr { $1 }
+| bitwise_and_attr AND equality_attr {BINARY(BAND ,$1 , $3)}
+;
+
+bitwise_xor_attr:
+ bitwise_and_attr { $1 }
+| bitwise_xor_attr CIRC bitwise_and_attr {BINARY(XOR ,$1 , $3)}
+;
+
+bitwise_or_attr:
+ bitwise_xor_attr { $1 }
+| bitwise_or_attr PIPE bitwise_xor_attr {BINARY(BOR ,$1 , $3)}
+;
+
+logical_and_attr:
+ bitwise_or_attr { $1 }
+| logical_and_attr AND_AND bitwise_or_attr {BINARY(AND ,$1 , $3)}
+;
+
+logical_or_attr:
+ logical_and_attr { $1 }
+| logical_or_attr PIPE_PIPE logical_and_attr {BINARY(OR ,$1 , $3)}
+;
+
+conditional_attr:
+ logical_or_attr { $1 }
+/* This is in conflict for now */
+| logical_or_attr QUEST conditional_attr COLON conditional_attr
+ { QUESTION($1, $3, $5) }
+
+
+attr: conditional_attr { $1 }
+;
+
+attr_list_ne:
+| attr { [$1] }
+| attr COMMA attr_list_ne { $1 :: $3 }
+| error COMMA attr_list_ne { $3 }
+;
+attr_list:
+ /* empty */ { [] }
+| attr_list_ne { $1 }
+;
+paren_attr_list_ne:
+ LPAREN attr_list_ne RPAREN { $2 }
+| LPAREN error RPAREN { [] }
+;
+paren_attr_list:
+ LPAREN attr_list RPAREN { $2 }
+| LPAREN error RPAREN { [] }
+;
+/*** GCC ASM instructions ***/
+asmattr:
+ /* empty */ { [] }
+| VOLATILE asmattr { ("volatile", []) :: $2 }
+| CONST asmattr { ("const", []) :: $2 }
+;
+asmtemplate:
+ one_string_constant { [$1] }
+| one_string_constant asmtemplate { $1 :: $2 }
+;
+asmoutputs:
+ /* empty */ { None }
+| COLON asmoperands asminputs
+ { let (ins, clobs) = $3 in
+ Some {aoutputs = $2; ainputs = ins; aclobbers = clobs} }
+;
+asmoperands:
+ /* empty */ { [] }
+| asmoperandsne { List.rev $1 }
+;
+asmoperandsne:
+ asmoperand { [$1] }
+| asmoperandsne COMMA asmoperand { $3 :: $1 }
+;
+asmoperand:
+ asmopname string_constant LPAREN expression RPAREN { ($1, fst $2, fst $4) }
+| asmopname string_constant LPAREN error RPAREN { ($1, fst $2, NOTHING ) }
+;
+asminputs:
+ /* empty */ { ([], []) }
+| COLON asmoperands asmclobber
+ { ($2, $3) }
+;
+asmopname:
+ /* empty */ { None }
+| LBRACKET IDENT RBRACKET { Some (fst $2) }
+;
+
+asmclobber:
+ /* empty */ { [] }
+| COLON asmcloberlst_ne { $2 }
+;
+asmcloberlst_ne:
+ one_string_constant { [$1] }
+| one_string_constant COMMA asmcloberlst_ne { $1 :: $3 }
+;
+
+%%
+
+
+
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Renaming of identifiers *)
+
+open C
+open Cutil
+
+module StringSet = Set.Make(String)
+
+type rename_env = {
+ re_id: ident IdentMap.t;
+ re_used: StringSet.t
+}
+
+let empty_env = { re_id = IdentMap.empty; re_used = StringSet.empty }
+
+(* For public global identifiers, we must keep their names *)
+
+let enter_global env id =
+ { re_id = IdentMap.add id id env.re_id;
+ re_used = StringSet.add id.name env.re_used }
+
+(* For static or local identifiers, we make up a new name if needed *)
+(* If the same identifier has already been declared,
+ don't rename a second time *)
+
+let rename env id =
+ if IdentMap.mem id env.re_id then (id, env) else begin
+ let basename =
+ if id.name = "" then Printf.sprintf "_%d" id.stamp else id.name in
+ let newname =
+ if not (StringSet.mem basename env.re_used) then basename else begin
+ let rec find_name n =
+ let s = Printf.sprintf "%s__%d" basename n in
+ if StringSet.mem s env.re_used
+ then find_name (n+1)
+ else s
+ in find_name 1
+ end in
+ let newid = {name = newname; stamp = id.stamp } in
+ ( newid,
+ { re_id = IdentMap.add id newid env.re_id;
+ re_used = StringSet.add newname env.re_used } )
+ end
+
+(* Monadic map to thread an environment *)
+
+let rec mmap (f: rename_env -> 'a -> 'b * rename_env) env = function
+ | [] -> ([], env)
+ | hd :: tl ->
+ let (hd', env1) = f env hd in
+ let (tl', env2) = mmap f env1 tl in
+ (hd' :: tl', env2)
+
+(* Renaming *)
+
+let ident env id =
+ try
+ IdentMap.find id env.re_id
+ with Not_found ->
+ Errors.fatal_error "Internal error: Rename: %s__%d unbound"
+ id.name id.stamp
+
+let rec typ env = function
+ | TPtr(ty, a) -> TPtr(typ env ty, a)
+ | TArray(ty, sz, a) -> TArray(typ env ty, sz, a)
+ | TFun(res, None, va, a) -> TFun(typ env res, None, va, a)
+ | TFun(res, Some p, va, a) ->
+ let (p', _) = mmap param env p in
+ TFun(typ env res, Some p', va, a)
+ | TNamed(id, a) -> TNamed(ident env id, a)
+ | TStruct(id, a) -> TStruct(ident env id, a)
+ | TUnion(id, a) -> TUnion(ident env id, a)
+ | ty -> ty
+
+and param env (id, ty) =
+ if id.name = "" then
+ ((id, typ env ty), env)
+ else
+ let (id', env') = rename env id in ((id', typ env' ty), env')
+
+let constant env = function
+ | CEnum(id, v) -> CEnum(ident env id, v)
+ | cst -> cst
+
+let rec exp env e =
+ { edesc = exp_desc env e.edesc; etyp = typ env e.etyp }
+
+and exp_desc env = function
+ | EConst cst -> EConst(constant env cst)
+ | ESizeof ty -> ESizeof(typ env ty)
+ | EVar id -> EVar(ident env id)
+ | EUnop(op, a) -> EUnop(op, exp env a)
+ | EBinop(op, a, b, ty) -> EBinop(op, exp env a, exp env b, typ env ty)
+ | EConditional(a, b, c) -> EConditional(exp env a, exp env b, exp env c)
+ | ECast(ty, a) -> ECast(typ env ty, exp env a)
+ | ECall(a, al) -> ECall(exp env a, List.map (exp env) al)
+
+let optexp env = function
+ | None -> None
+ | Some a -> Some (exp env a)
+
+let field env f =
+ { fld_name = f.fld_name;
+ fld_typ = typ env f.fld_typ;
+ fld_bitfield = f.fld_bitfield }
+
+let rec init env = function
+ | Init_single e -> Init_single(exp env e)
+ | Init_array il -> Init_array (List.map (init env) il)
+ | Init_struct(id, il) ->
+ Init_struct(ident env id,
+ List.map (fun (f, i) -> (field env f, init env i)) il)
+ | Init_union(id, f, i) ->
+ Init_union(ident env id, field env f, init env i)
+
+let decl env (sto, id, ty, int) =
+ let (id', env') = rename env id in
+ ((sto,
+ id',
+ typ env' ty,
+ match int with None -> None | Some i -> Some(init env' i)),
+ env')
+
+let rec stmt env s =
+ { sdesc = stmt_desc env s.sdesc; sloc = s.sloc }
+
+and stmt_desc env = function
+ | Sskip -> Sskip
+ | Sdo a -> Sdo (exp env a)
+ | Sseq(s1, s2) -> Sseq(stmt env s1, stmt env s2)
+ | Sif(a, s1, s2) -> Sif(exp env a, stmt env s1, stmt env s2)
+ | Swhile(a, s) -> Swhile(exp env a, stmt env s)
+ | Sdowhile(s, a) -> Sdowhile(stmt env s, exp env a)
+ | Sfor(a1, a2, a3, s) ->
+ Sfor(stmt env a1, exp env a2, stmt env a3, stmt env s)
+ | Sbreak -> Sbreak
+ | Scontinue -> Scontinue
+ | Sswitch(a, s) -> Sswitch(exp env a, stmt env s)
+ | Slabeled(lbl, s) -> Slabeled(slabel env lbl, stmt env s)
+ | Sgoto lbl -> Sgoto lbl
+ | Sreturn a -> Sreturn (optexp env a)
+ | Sblock sl -> let (sl', _) = mmap stmt_or_decl env sl in Sblock sl'
+ | Sdecl d -> assert false
+
+and stmt_or_decl env s =
+ match s.sdesc with
+ | Sdecl d ->
+ let (d', env') = decl env d in
+ ({ sdesc = Sdecl d'; sloc = s.sloc}, env')
+ | _ ->
+ (stmt env s, env)
+
+and slabel env = function
+ | Scase e -> Scase(exp env e)
+ | sl -> sl
+
+let fundef env f =
+ let (name', env0) = rename env f.fd_name in
+ let (params', env1) = mmap param env0 f.fd_params in
+ let (locals', env2) = mmap decl env1 f.fd_locals in
+ ( { fd_storage = f.fd_storage;
+ fd_inline = f.fd_inline;
+ fd_name = name';
+ fd_ret = typ env0 f.fd_ret;
+ fd_params = params';
+ fd_vararg = f.fd_vararg;
+ fd_locals = locals';
+ fd_body = stmt env2 f.fd_body },
+ env0 )
+
+let enum env (id, opte) =
+ let (id', env') = rename env id in
+ ((id', optexp env' opte), env')
+
+let rec globdecl env g =
+ let (desc', env') = globdecl_desc env g.gdesc in
+ ( { gdesc = desc'; gloc = g.gloc }, env' )
+
+and globdecl_desc env = function
+ | Gdecl d ->
+ let (d', env') = decl env d in
+ (Gdecl d', env')
+ | Gfundef fd ->
+ let (fd', env') = fundef env fd in
+ (Gfundef fd', env')
+ | Gcompositedecl(kind, id) ->
+ let (id', env') = rename env id in
+ (Gcompositedecl(kind, id'), env')
+ | Gcompositedef(kind, id, members) ->
+ (Gcompositedef(kind, ident env id, List.map (field env) members), env)
+ | Gtypedef(id, ty) ->
+ let (id', env') = rename env id in
+ (Gtypedef(id', typ env' ty), env')
+ | Genumdef(id, members) ->
+ let (id', env') = rename env id in
+ let (members', env'') = mmap enum env' members in
+ (Genumdef(id', members'), env'')
+ | Gpragma s ->
+ (Gpragma s, env)
+
+let rec globdecls env accu = function
+ | [] -> List.rev accu
+ | dcl :: rem ->
+ let (dcl', env') = globdecl env dcl in
+ globdecls env' (dcl' :: accu) rem
+
+(* Reserve names of builtins *)
+
+let reserve_builtins () =
+ List.fold_left enter_global empty_env (Builtins.identifiers())
+
+(* Reserve global declarations with public visibility *)
+
+let rec reserve_public env = function
+ | [] -> env
+ | dcl :: rem ->
+ let env' =
+ match dcl.gdesc with
+ | Gdecl(sto, id, _, _) ->
+ begin match sto with
+ | Storage_default | Storage_extern -> enter_global env id
+ | Storage_static -> env
+ | _ -> assert false
+ end
+ | Gfundef f ->
+ begin match f.fd_storage with
+ | Storage_default | Storage_extern -> enter_global env f.fd_name
+ | Storage_static -> env
+ | _ -> assert false
+ end
+ | _ -> env in
+ reserve_public env' rem
+
+(* Rename the program *)
+
+let program p =
+ globdecls
+ (reserve_public (reserve_builtins()) p)
+ [] p
+
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val program : C.program -> C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Pulling side-effects out of expressions *)
+
+(* Assumes: nothing
+ Produces: simplified code *)
+
+open C
+open Cutil
+open Transform
+
+(* Grammar of simplified expressions:
+ e ::= EConst cst
+ | ESizeof ty
+ | EVar id
+ | EUnop pure-unop e
+ | EBinop pure-binop e e
+ | EConditional e e e
+ | ECast ty e
+
+ Grammar of statements produced to reflect side-effects in expressions:
+ s ::= Sskip
+ | Sdo (EBinop Oassign e e)
+ | Sdo (EBinop Oassign e (ECall e e* ))
+ | Sdo (Ecall e el)
+ | Sseq s s
+ | Sif e s s
+*)
+
+let rec is_simpl_expr e =
+ match e.edesc with
+ | EConst cst -> true
+ | ESizeof ty -> true
+ | EVar id -> true
+ | EUnop((Ominus|Oplus|Olognot|Onot|Oderef|Oaddrof), e1) ->
+ is_simpl_expr e1
+ | EBinop((Oadd|Osub|Omul|Odiv|Omod|Oand|Oor|Oxor|Oshl|Oshr|
+ Oeq|One|Olt|Ogt|Ole|Oge|Oindex|Ologand|Ologor), e1, e2, _) ->
+ is_simpl_expr e1 && is_simpl_expr e2
+ | EConditional(e1, e2, e3) ->
+ is_simpl_expr e1 && is_simpl_expr e2 && is_simpl_expr e3
+ | ECast(ty, e1) ->
+ is_simpl_expr e1
+ | _ ->
+ false
+
+(* "Destination" of a simplified expression *)
+
+type exp_destination =
+ | RHS (* evaluate as a r-value *)
+ | LHS (* evaluate as a l-value *)
+ | Drop (* drop its value, we only need the side-effects *)
+ | Set of exp (* assign it to the given simplified l.h.s. *)
+
+let voidconst = { nullconst with etyp = TVoid [] }
+
+(* Reads from volatile lvalues are also considered as side-effects if
+ [volatilize] is true. *)
+
+let volatilize = ref false
+
+(* [simpl_expr loc env e act] returns a pair [s, e'] of
+ a statement that performs the side-effects present in [e] and
+ a simplified, side-effect-free expression [e'].
+ If [act] is [RHS], [e'] evaluates to the same value as [e].
+ If [act] is [LHS], [e'] evaluates to the same location as [e].
+ If [act] is [Drop], [e'] is not meaningful and must be ignored.
+ If [act] is [Set lhs], [s] also performs an assignment
+ equivalent to [lhs = e]. [e'] is not meaningful. *)
+
+let simpl_expr loc env e act =
+
+ (* Temporaries should not be [const] because we assign into them,
+ and need not be [volatile] because no one else is writing into them.
+ As for [restrict] it doesn't make sense anyway. *)
+
+ let new_temp ty =
+ Transform.new_temp (erase_attributes_type env ty) in
+
+ let eboolvalof e =
+ { edesc = EBinop(One, e, intconst 0L IInt, TInt(IInt, []));
+ etyp = TInt(IInt, []) } in
+
+ let sseq s1 s2 = Cutil.sseq loc s1 s2 in
+
+ let sassign e1 e2 =
+ { sdesc = Sdo {edesc = EBinop(Oassign, e1, e2, e1.etyp); etyp = e1.etyp};
+ sloc = loc } in
+
+ let sif e s1 s2 =
+ { sdesc = Sif(e, s1, s2); sloc = loc } in
+
+ let is_volatile_read e =
+ !volatilize
+ && List.mem AVolatile (attributes_of_type env e.etyp)
+ && is_lvalue env e in
+
+ let lhs_to_rhs e =
+ if is_volatile_read e
+ then (let t = new_temp e.etyp in (sassign t e, t))
+ else (sskip, e) in
+
+ let finish act s e =
+ match act with
+ | RHS ->
+ if is_volatile_read e
+ then (let t = new_temp e.etyp in (sseq s (sassign t e), t))
+ else (s, e)
+ | LHS ->
+ (s, e)
+ | Drop ->
+ if is_volatile_read e
+ then (let t = new_temp e.etyp in (sseq s (sassign t e), voidconst))
+ else (s, voidconst)
+ | Set lhs ->
+ if is_volatile_read e
+ then (let t = new_temp e.etyp in
+ (sseq s (sseq (sassign t e) (sassign lhs t)), voidconst))
+ else (sseq s (sassign lhs e), voidconst) in
+
+ let rec simpl e act =
+ match e.edesc with
+
+ | EConst cst ->
+ finish act sskip e
+
+ | ESizeof ty ->
+ finish act sskip e
+
+ | EVar id ->
+ finish act sskip e
+
+ | EUnop(op, e1) ->
+
+ begin match op with
+
+ | Ominus | Oplus | Olognot | Onot | Oderef | Oarrow _ ->
+ let (s1, e1') = simpl e1 RHS in
+ finish act s1 {edesc = EUnop(op, e1'); etyp = e.etyp}
+
+ | Oaddrof ->
+ let (s1, e1') = simpl e1 LHS in
+ finish act s1 {edesc = EUnop(op, e1'); etyp = e.etyp}
+
+ | Odot _ ->
+ let (s1, e1') = simpl e1 (if act = LHS then LHS else RHS) in
+ finish act s1 {edesc = EUnop(op, e1'); etyp = e.etyp}
+
+ | Opreincr | Opredecr ->
+ let (s1, e1') = simpl e1 LHS in
+ let (s2, e2') = lhs_to_rhs e1' in
+ let op' = match op with Opreincr -> Oadd | _ -> Osub in
+ let ty = unary_conversion env e.etyp in
+ let e3 =
+ {edesc = EBinop(op', e2', intconst 1L IInt, ty); etyp = ty} in
+ begin match act with
+ | Drop ->
+ (sseq s1 (sseq s2 (sassign e1' e3)), voidconst)
+ | _ ->
+ let tmp = new_temp e.etyp in
+ finish act (sseq s1 (sseq s2 (sseq (sassign tmp e3)
+ (sassign e1' tmp))))
+ tmp
+ end
+
+ | Opostincr | Opostdecr ->
+ let (s1, e1') = simpl e1 LHS in
+ let op' = match op with Opostincr -> Oadd | _ -> Osub in
+ let ty = unary_conversion env e.etyp in
+ begin match act with
+ | Drop ->
+ let (s2, e2') = lhs_to_rhs e1' in
+ let e3 =
+ {edesc = EBinop(op', e2', intconst 1L IInt, ty); etyp = ty} in
+ (sseq s1 (sseq s2 (sassign e1' e3)), voidconst)
+ | _ ->
+ let tmp = new_temp e.etyp in
+ let e3 =
+ {edesc = EBinop(op', tmp, intconst 1L IInt, ty); etyp = ty} in
+ finish act (sseq s1 (sseq (sassign tmp e1') (sassign e1' e3)))
+ tmp
+ end
+
+ end
+
+ | EBinop(op, e1, e2, ty) ->
+
+ begin match op with
+
+ | Oadd | Osub | Omul | Odiv | Omod | Oand | Oor | Oxor
+ | Oshl | Oshr | Oeq | One | Olt | Ogt | Ole | Oge | Oindex ->
+ let (s1, e1') = simpl e1 RHS in
+ let (s2, e2') = simpl e2 RHS in
+ finish act (sseq s1 s2)
+ {edesc = EBinop(op, e1', e2', ty); etyp = e.etyp}
+
+ | Oassign ->
+ if act = Drop && is_simpl_expr e1 then
+ simpl e2 (Set e1)
+ else begin
+ match act with
+ | Drop ->
+ let (s1, e1') = simpl e1 LHS in
+ let (s2, e2') = simpl e2 RHS in
+ (sseq s1 (sseq s2 (sassign e1' e2')), voidconst)
+ | _ ->
+ let tmp = new_temp e.etyp in
+ let (s1, e1') = simpl e1 LHS in
+ let (s2, e2') = simpl e2 (Set tmp) in
+ finish act (sseq s1 (sseq s2 (sassign e1' tmp)))
+ tmp
+ end
+
+ | Oadd_assign | Osub_assign | Omul_assign | Odiv_assign
+ | Omod_assign | Oand_assign | Oor_assign | Oxor_assign
+ | Oshl_assign | Oshr_assign ->
+ let (s1, e1') = simpl e1 LHS in
+ let (s11, e11') = lhs_to_rhs e1' in
+ let (s2, e2') = simpl e2 RHS in
+ let op' =
+ match op with
+ | Oadd_assign -> Oadd | Osub_assign -> Osub
+ | Omul_assign -> Omul | Odiv_assign -> Odiv
+ | Omod_assign -> Omod | Oand_assign -> Oand
+ | Oor_assign -> Oor | Oxor_assign -> Oxor
+ | Oshl_assign -> Oshl | Oshr_assign -> Oshr
+ | _ -> assert false in
+ let e3 =
+ { edesc = EBinop(op', e11', e2', ty); etyp = ty } in
+ begin match act with
+ | Drop ->
+ (sseq s1 (sseq s11 (sseq s2 (sassign e1' e3))), voidconst)
+ | _ ->
+ let tmp = new_temp e.etyp in
+ finish act (sseq s1 (sseq s11 (sseq s2
+ (sseq (sassign tmp e3) (sassign e1' tmp)))))
+ tmp
+ end
+
+ | Ocomma ->
+ let (s1, _) = simpl e1 Drop in
+ let (s2, e2') = simpl e2 act in
+ (sseq s1 s2, e2')
+
+ | Ologand ->
+ let (s1, e1') = simpl e1 RHS in
+ if is_simpl_expr e2 then begin
+ finish act s1
+ {edesc = EBinop(Ologand, e1', e2, ty); etyp = e.etyp}
+ end else begin
+ match act with
+ | Drop ->
+ let (s2, _) = simpl e2 Drop in
+ (sseq s1 (sif e1' s2 sskip), voidconst)
+ | RHS | LHS -> (* LHS should not happen *)
+ let (s2, e2') = simpl e2 RHS in
+ let tmp = new_temp e.etyp in
+ (sseq s1 (sif e1'
+ (sseq s2 (sassign tmp (eboolvalof e2')))
+ (sassign tmp (intconst 0L IInt))),
+ tmp)
+ | Set lv ->
+ let (s2, e2') = simpl e2 RHS in
+ (sseq s1 (sif e1'
+ (sseq s2 (sassign lv (eboolvalof e2')))
+ (sassign lv (intconst 0L IInt))),
+ voidconst)
+ end
+
+ | Ologor ->
+ let (s1, e1') = simpl e1 RHS in
+ if is_simpl_expr e2 then begin
+ finish act s1
+ {edesc = EBinop(Ologor, e1', e2, ty); etyp = e.etyp}
+ end else begin
+ match act with
+ | Drop ->
+ let (s2, _) = simpl e2 Drop in
+ (sseq s1 (sif e1' sskip s2), voidconst)
+ | RHS | LHS -> (* LHS should not happen *)
+ let (s2, e2') = simpl e2 RHS in
+ let tmp = new_temp e.etyp in
+ (sseq s1 (sif e1'
+ (sassign tmp (intconst 1L IInt))
+ (sseq s2 (sassign tmp (eboolvalof e2')))),
+ tmp)
+ | Set lv ->
+ let (s2, e2') = simpl e2 RHS in
+ (sseq s1 (sif e1'
+ (sassign lv (intconst 1L IInt))
+ (sseq s2 (sassign lv (eboolvalof e2')))),
+ voidconst)
+ end
+
+ end
+
+ | EConditional(e1, e2, e3) ->
+ let (s1, e1') = simpl e1 RHS in
+ if is_simpl_expr e2 && is_simpl_expr e3 then begin
+ finish act s1 {edesc = EConditional(e1', e2, e3); etyp = e.etyp}
+ end else begin
+ match act with
+ | Drop ->
+ let (s2, _) = simpl e2 Drop in
+ let (s3, _) = simpl e3 Drop in
+ (sseq s1 (sif e1' s2 s3), voidconst)
+ | RHS | LHS -> (* LHS should not happen *)
+ let tmp = new_temp e.etyp in
+ let (s2, _) = simpl e2 (Set tmp) in
+ let (s3, _) = simpl e3 (Set tmp) in
+ (sseq s1 (sif e1' s2 s3), tmp)
+ | Set lv ->
+ let (s2, _) = simpl e2 (Set lv) in
+ let (s3, _) = simpl e3 (Set lv) in
+ (sseq s1 (sif e1' s2 s3), voidconst)
+ end
+
+ | ECast(ty, e1) ->
+ if is_void_type env ty then begin
+ if act <> Drop then
+ Errors.warning "%acast to 'void' in a context expecting a value\n"
+ formatloc loc;
+ simpl e1 act
+ end else begin
+ let (s1, e1') = simpl e1 RHS in
+ finish act s1 {edesc = ECast(ty, e1'); etyp = e.etyp}
+ end
+
+ | ECall(e1, el) ->
+ let (s1, e1') = simpl e1 RHS in
+ let (s2, el') = simpl_list el in
+ let e2 = { edesc = ECall(e1', el'); etyp = e.etyp } in
+ begin match act with
+ | Drop ->
+ (sseq s1 (sseq s2 {sdesc = Sdo e2; sloc=loc}), voidconst)
+ | Set({edesc = EVar _} as lhs) ->
+ (* CompCert wants the destination of a call to be a variable,
+ not a more complex lhs. In the latter case, we
+ fall through the catch-all case below *)
+ (sseq s1 (sseq s2 (sassign lhs e2)), voidconst)
+ | _ ->
+ let tmp = new_temp e.etyp in
+ finish act (sseq s1 (sseq s2 (sassign tmp e2))) tmp
+ end
+
+ and simpl_list = function
+ | [] -> (sskip, [])
+ | e1 :: el ->
+ let (s1, e1') = simpl e1 RHS in
+ let (s2, el') = simpl_list el in
+ (sseq s1 s2, e1' :: el')
+
+ in simpl e act
+
+(* Simplification of an initializer *)
+
+let simpl_initializer loc env i =
+
+ let rec simpl_init = function
+ | Init_single e ->
+ let (s, e') = simpl_expr loc env e RHS in
+ (s, Init_single e)
+ | Init_array il ->
+ let rec simpl = function
+ | [] -> (sskip, [])
+ | i1 :: il ->
+ let (s1, i1') = simpl_init i1 in
+ let (s2, il') = simpl il in
+ (sseq loc s1 s2, i1' :: il') in
+ let (s, il') = simpl il in
+ (s, Init_array il')
+ | Init_struct(id, il) ->
+ let rec simpl = function
+ | [] -> (sskip, [])
+ | (f1, i1) :: il ->
+ let (s1, i1') = simpl_init i1 in
+ let (s2, il') = simpl il in
+ (sseq loc s1 s2, (f1, i1') :: il') in
+ let (s, il') = simpl il in
+ (s, Init_struct(id, il'))
+ | Init_union(id, f, i) ->
+ let (s, i') = simpl_init i in
+ (s, Init_union(id, f, i'))
+
+ in simpl_init i
+
+(* Construct a simplified statement equivalent to [if (e) s1; else s2;].
+ Optimizes the case where e contains [&&] or [||] or [?].
+ [s1] or [s2] can be duplicated, so use only for small [s1] and [s2]
+ that do not define any labels. *)
+
+let rec simpl_if loc env e s1 s2 =
+ match e.edesc with
+ | EUnop(Olognot, e1) ->
+ simpl_if loc env e1 s2 s1
+ | EBinop(Ologand, e1, e2, _) ->
+ simpl_if loc env e1
+ (simpl_if loc env e2 s1 s2)
+ s2
+ | EBinop(Ologor, e1, e2, _) ->
+ simpl_if loc env e1
+ s1
+ (simpl_if loc env e2 s1 s2)
+ | EConditional(e1, e2, e3) ->
+ simpl_if loc env e1
+ (simpl_if loc env e2 s1 s2)
+ (simpl_if loc env e3 s1 s2)
+ | _ ->
+ let (s, e') = simpl_expr loc env e RHS in
+ sseq loc s {sdesc = Sif(e', s1, s2); sloc = loc}
+
+(* Trivial statements for which [simpl_if] is applicable *)
+
+let trivial_stmt s =
+ match s.sdesc with
+ | Sskip | Scontinue | Sbreak | Sgoto _ -> true
+ | _ -> false
+
+(* Construct a simplified statement equivalent to [if (!e) exit; ]. *)
+
+let break_if_false loc env e =
+ simpl_if loc env e
+ {sdesc = Sskip; sloc = loc}
+ {sdesc = Sbreak; sloc = loc}
+
+(* Simplification of a statement *)
+
+let simpl_statement env s =
+
+ let rec simpl_stmt s =
+ match s.sdesc with
+
+ | Sskip ->
+ s
+
+ | Sdo e ->
+ let (s', _) = simpl_expr s.sloc env e Drop in
+ s'
+
+ | Sseq(s1, s2) ->
+ {sdesc = Sseq(simpl_stmt s1, simpl_stmt s2); sloc = s.sloc}
+
+ | Sif(e, s1, s2) ->
+ if trivial_stmt s1 && trivial_stmt s2 then
+ simpl_if s.sloc env e (simpl_stmt s1) (simpl_stmt s2)
+ else begin
+ let (s', e') = simpl_expr s.sloc env e RHS in
+ sseq s.sloc s'
+ {sdesc = Sif(e', simpl_stmt s1, simpl_stmt s2);
+ sloc = s.sloc}
+ end
+
+ | Swhile(e, s1) ->
+ if is_simpl_expr e then
+ {sdesc = Swhile(e, simpl_stmt s1); sloc = s.sloc}
+ else
+ {sdesc =
+ Swhile(intconst 1L IInt,
+ sseq s.sloc (break_if_false s.sloc env e)
+ (simpl_stmt s1));
+ sloc = s.sloc}
+
+ | Sdowhile(s1, e) ->
+ if is_simpl_expr e then
+ {sdesc = Sdowhile(simpl_stmt s1, e); sloc = s.sloc}
+ else begin
+ let tmp = new_temp (TInt(IInt, [])) in
+ let (s', _) = simpl_expr s.sloc env e (Set tmp) in
+ let s_init =
+ {sdesc = Sdo {edesc = EBinop(Oassign, tmp, intconst 1L IInt, tmp.etyp);
+ etyp = tmp.etyp};
+ sloc = s.sloc} in
+ {sdesc = Sfor(s_init, tmp, s', simpl_stmt s1); sloc = s.sloc}
+ end
+(*** Alternate translation that unfortunately puts a "break" in the
+ "next" part of a "for", something that is not supported
+ by Clight semantics, and has unknown behavior in gcc.
+ {sdesc =
+ Sfor(sskip,
+ intconst 1L IInt,
+ break_if_false s.sloc env e,
+ simpl_stmt s1);
+ sloc = s.sloc}
+***)
+
+ | Sfor(s1, e, s2, s3) ->
+ if is_simpl_expr e then
+ {sdesc = Sfor(simpl_stmt s1,
+ e,
+ simpl_stmt s2,
+ simpl_stmt s3);
+ sloc = s.sloc}
+ else
+ let (s', e') = simpl_expr s.sloc env e RHS in
+ {sdesc = Sfor(sseq s.sloc (simpl_stmt s1) s',
+ e',
+ sseq s.sloc (simpl_stmt s2) s',
+ simpl_stmt s3);
+ sloc = s.sloc}
+
+ | Sbreak ->
+ s
+ | Scontinue ->
+ s
+
+ | Sswitch(e, s1) ->
+ let (s', e') = simpl_expr s.sloc env e RHS in
+ sseq s.sloc s' {sdesc = Sswitch(e', simpl_stmt s1); sloc = s.sloc}
+
+ | Slabeled(lbl, s1) ->
+ {sdesc = Slabeled(lbl, simpl_stmt s1); sloc = s.sloc}
+
+ | Sgoto lbl ->
+ s
+
+ | Sreturn None ->
+ s
+
+ | Sreturn (Some e) ->
+ let (s', e') = simpl_expr s.sloc env e RHS in
+ sseq s.sloc s' {sdesc = Sreturn(Some e'); sloc = s.sloc}
+
+ | Sblock sl ->
+ {sdesc = Sblock(simpl_block sl); sloc = s.sloc}
+
+ | Sdecl d -> assert false
+
+ and simpl_block = function
+ | [] -> []
+ | ({sdesc = Sdecl(sto, id, ty, None)} as s) :: sl ->
+ s :: simpl_block sl
+ | ({sdesc = Sdecl(sto, id, ty, Some i)} as s) :: sl ->
+ let (s', i') = simpl_initializer s.sloc env i in
+ let sl' =
+ {sdesc = Sdecl(sto, id, ty, Some i'); sloc = s.sloc}
+ :: simpl_block sl in
+ if s'.sdesc = Sskip then sl' else s' :: sl'
+ | s :: sl ->
+ simpl_stmt s :: simpl_block sl
+
+ in simpl_stmt s
+
+(* Simplification of a function definition *)
+
+let simpl_fundef env f =
+ reset_temps();
+ let body' = simpl_statement env f.fd_body in
+ let temps = get_temps() in
+ { f with fd_locals = f.fd_locals @ temps; fd_body = body' }
+
+(* Entry point *)
+
+let program ?(volatile = false) p =
+ volatilize := volatile;
+ Transform.program ~fundef:simpl_fundef p
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Pulling side effects out of expressions.
+ If [volatile] is [true], treats reads from volatile rvalues
+ as side-effects *)
+
+val program: ?volatile: bool -> C.program -> C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Expand assignments between structs and between unions *)
+
+(* Assumes: simplified code.
+ Preserves: simplified code, unblocked code *)
+
+open C
+open Cutil
+open Env
+open Errors
+
+let maxsize = ref 8
+
+let need_memcpy = ref (None: ident option)
+
+let memcpy_type =
+ TFun(TPtr(TVoid [], []),
+ Some [(Env.fresh_ident "", TPtr(TVoid [], []));
+ (Env.fresh_ident "", TPtr(TVoid [AConst], []));
+ (Env.fresh_ident "", TInt(size_t_ikind, []))],
+ false, [])
+
+let memcpy_ident () =
+ match !need_memcpy with
+ | None ->
+ let id = Env.fresh_ident "memcpy" in
+ need_memcpy := Some id;
+ id
+ | Some id ->
+ id
+
+let transf_assign env loc lhs rhs =
+
+ let num_assign = ref 0 in
+
+ let assign l r =
+ incr num_assign;
+ if !num_assign > !maxsize
+ then raise Exit
+ else sassign loc l r in
+
+ let rec transf l r =
+ match unroll env l.etyp with
+ | TStruct(id, attr) ->
+ let ci = Env.find_struct env id in
+ if ci.ci_sizeof = None then
+ error "%a: Error: incomplete struct '%s'" formatloc loc id.name;
+ transf_struct l r ci.ci_members
+ | TUnion(id, attr) ->
+ raise Exit
+ | TArray(ty_elt, Some sz, attr) ->
+ transf_array l r ty_elt 0L sz
+ | TArray(ty_elt, None, attr) ->
+ error "%a: Error: array of unknown size" formatloc loc;
+ sskip (* will be ignored later *)
+ | _ ->
+ assign l r
+
+ and transf_struct l r = function
+ | [] -> sskip
+ | f :: fl ->
+ sseq loc (transf {edesc = EUnop(Odot f.fld_name, l); etyp = f.fld_typ}
+ {edesc = EUnop(Odot f.fld_name, r); etyp = f.fld_typ})
+ (transf_struct l r fl)
+
+ and transf_array l r ty idx sz =
+ if idx >= sz then sskip else begin
+ let e = intconst idx size_t_ikind in
+ sseq loc (transf {edesc = EBinop(Oindex, l, e, ty); etyp = ty}
+ {edesc = EBinop(Oindex, r, e, ty); etyp = ty})
+ (transf_array l r ty (Int64.add idx 1L) sz)
+ end
+ in
+
+ try
+ transf lhs rhs
+ with Exit ->
+ let memcpy = {edesc = EVar(memcpy_ident()); etyp = memcpy_type} in
+ let e_lhs = {edesc = EUnop(Oaddrof, lhs); etyp = TPtr(lhs.etyp, [])} in
+ let e_rhs = {edesc = EUnop(Oaddrof, rhs); etyp = TPtr(rhs.etyp, [])} in
+ let e_size = {edesc = ESizeof(lhs.etyp); etyp = TInt(size_t_ikind, [])} in
+ {sdesc = Sdo {edesc = ECall(memcpy, [e_lhs; e_rhs; e_size]);
+ etyp = TVoid[]};
+ sloc = loc}
+
+let rec transf_stmt env s =
+ match s.sdesc with
+ | Sskip -> s
+ | Sdo {edesc = EBinop(Oassign, lhs, rhs, _)}
+ when is_composite_type env lhs.etyp ->
+ transf_assign env s.sloc lhs rhs
+ | Sdo _ -> s
+ | Sseq(s1, s2) ->
+ {s with sdesc = Sseq(transf_stmt env s1, transf_stmt env s2)}
+ | Sif(e, s1, s2) ->
+ {s with sdesc = Sif(e, transf_stmt env s1, transf_stmt env s2)}
+ | Swhile(e, s1) ->
+ {s with sdesc = Swhile(e, transf_stmt env s1)}
+ | Sdowhile(s1, e) ->
+ {s with sdesc = Sdowhile(transf_stmt env s1, e)}
+ | Sfor(s1, e, s2, s3) ->
+ {s with sdesc = Sfor(transf_stmt env s1, e,
+ transf_stmt env s2, transf_stmt env s3)}
+ | Sbreak -> s
+ | Scontinue -> s
+ | Sswitch(e, s1) ->
+ {s with sdesc = Sswitch(e, transf_stmt env s1)}
+ | Slabeled(lbl, s1) ->
+ {s with sdesc = Slabeled(lbl, transf_stmt env s1)}
+ | Sgoto lbl -> s
+ | Sreturn _ -> s
+ | Sblock sl ->
+ {s with sdesc = Sblock(List.map (transf_stmt env) sl)}
+ | Sdecl d -> s
+
+let transf_fundef env fd =
+ {fd with fd_body = transf_stmt env fd.fd_body}
+
+let program p =
+ need_memcpy := None;
+ let p' = Transform.program ~fundef:transf_fundef p in
+ match !need_memcpy with
+ | None -> p'
+ | Some id ->
+ {gdesc = Gdecl(Storage_extern, id, memcpy_type, None); gloc = no_loc}
+ :: p'
+
+(* Horrible hack *)
+(***
+ let has_memcpy = ref false in
+ need_memcpy := None;
+ List.iter
+ (function {gdesc = Gdecl(_, ({name = "memcpy"} as id), _, _)} ->
+ need_memcpy := Some id; has_memcpy := true
+ | _ -> ())
+ p;
+ let p' = Transform.program ~fundef:transf_fundef p in
+ match !need_memcpy with
+ | Some id when not !has_memcpy ->
+ {gdesc = Gdecl(Storage_extern, id, memcpy_type, None); gloc = no_loc}
+ :: p'
+ | _ -> p'
+***)
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Expand assignments between structs and between unions *)
+
+val program: C.program -> C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Eliminate by-value passing of structs and unions. *)
+
+(* Assumes: nothing.
+ Preserves: simplified code, unblocked code *)
+
+open C
+open Cutil
+open Transform
+
+(* In function argument types, struct s -> struct s *
+ In function result types, struct s -> void + add 1st parameter struct s *
+ Try to preserve original typedef names when no change.
+*)
+
+let rec transf_type env t =
+ match unroll env t with
+ | TFun(tres, None, vararg, attr) ->
+ let tres' = transf_type env tres in
+ TFun((if is_composite_type env tres then TVoid [] else tres'),
+ None, vararg, attr)
+ | TFun(tres, Some args, vararg, attr) ->
+ let args' = List.map (transf_funarg env) args in
+ let tres' = transf_type env tres in
+ if is_composite_type env tres then begin
+ let res = Env.fresh_ident "_res" in
+ TFun(TVoid [], Some((res, TPtr(tres', [])) :: args'), vararg, attr)
+ end else
+ TFun(tres', Some args', vararg, attr)
+ | TPtr(t1, attr) ->
+ let t1' = transf_type env t1 in
+ if t1' = t1 then t else TPtr(transf_type env t1, attr)
+ | TArray(t1, sz, attr) ->
+ let t1' = transf_type env t1 in
+ if t1' = t1 then t else TArray(transf_type env t1, sz, attr)
+ | _ -> t
+
+and transf_funarg env (id, t) =
+ let t = transf_type env t in
+ if is_composite_type env t
+ then (id, TPtr(add_attributes_type [AConst] t, []))
+ else (id, t)
+
+(* Simple exprs: no change in structure, since calls cannot occur within,
+ but need to rewrite the types. *)
+
+let rec transf_expr env e =
+ { etyp = transf_type env e.etyp;
+ edesc = match e.edesc with
+ | EConst c -> EConst c
+ | ESizeof ty -> ESizeof (transf_type env ty)
+ | EVar x -> EVar x
+ | EUnop(op, e1) -> EUnop(op, transf_expr env e1)
+ | EBinop(op, e1, e2, ty) ->
+ EBinop(op, transf_expr env e1, transf_expr env e2, transf_type env ty)
+ | EConditional(e1, e2, e3) ->
+ assert (not (is_composite_type env e.etyp));
+ EConditional(transf_expr env e1, transf_expr env e2, transf_expr env e3)
+ | ECast(ty, e1) -> ECast(transf_type env ty, transf_expr env e1)
+ | ECall(e1, el) -> assert false
+ }
+
+(* Initializers *)
+
+let rec transf_init env = function
+ | Init_single e ->
+ Init_single (transf_expr env e)
+ | Init_array il ->
+ Init_array (List.map (transf_init env) il)
+ | Init_struct(id, fil) ->
+ Init_struct (id, List.map (fun (fld, i) -> (fld, transf_init env i)) fil)
+ | Init_union(id, fld, i) ->
+ Init_union(id, fld, transf_init env i)
+
+(* Declarations *)
+
+let transf_decl env (sto, id, ty, init) =
+ (sto, id, transf_type env ty,
+ match init with None -> None | Some i -> Some (transf_init env i))
+
+(* Transformation of statements and function bodies *)
+
+let transf_funbody env body optres =
+
+let transf_type t = transf_type env t
+and transf_expr e = transf_expr env e in
+
+(* Function arguments: pass by reference those having struct/union type *)
+
+let transf_arg e =
+ let e' = transf_expr e in
+ if is_composite_type env e'.etyp
+ then {edesc = EUnop(Oaddrof, e'); etyp = TPtr(e'.etyp, [])}
+ else e'
+in
+
+(* Function calls: if return type is struct or union,
+ lv = f(...) -> f(&lv, ...)
+ f(...) -> f(&newtemp, ...)
+ Returns: if return type is struct or union,
+ return x -> _res = x; return
+*)
+
+let rec transf_stmt s =
+ match s.sdesc with
+ | Sskip -> s
+ | Sdo {edesc = ECall(fn, args); etyp = ty} ->
+ let fn = transf_expr fn in
+ let args = List.map transf_arg args in
+ if is_composite_type env ty then begin
+ let tmp = new_temp ~name:"_res" ty in
+ let arg0 = {edesc = EUnop(Oaddrof, tmp); etyp = TPtr(ty, [])} in
+ {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}}
+ end else
+ {s with sdesc = Sdo {edesc = ECall(fn, args); etyp = ty}}
+ | Sdo {edesc = EBinop(Oassign, dst, {edesc = ECall(fn, args); etyp = ty}, _)} ->
+ let dst = transf_expr dst in
+ let fn = transf_expr fn in
+ let args = List.map transf_arg args in
+ let ty = transf_type ty in
+ if is_composite_type env ty then begin
+ let arg0 = {edesc = EUnop(Oaddrof, dst); etyp = TPtr(dst.etyp, [])} in
+ {s with sdesc = Sdo {edesc = ECall(fn, arg0 :: args); etyp = TVoid []}}
+ end else
+ sassign s.sloc dst {edesc = ECall(fn, args); etyp = ty}
+ | Sdo e ->
+ {s with sdesc = Sdo(transf_expr e)}
+ | Sseq(s1, s2) ->
+ {s with sdesc = Sseq(transf_stmt s1, transf_stmt s2)}
+ | Sif(e, s1, s2) ->
+ {s with sdesc = Sif(transf_expr e, transf_stmt s1, transf_stmt s2)}
+ | Swhile(e, s1) ->
+ {s with sdesc = Swhile(transf_expr e, transf_stmt s1)}
+ | Sdowhile(s1, e) ->
+ {s with sdesc = Sdowhile(transf_stmt s1, transf_expr e)}
+ | Sfor(s1, e, s2, s3) ->
+ {s with sdesc = Sfor(transf_stmt s1, transf_expr e,
+ transf_stmt s2, transf_stmt s3)}
+ | Sbreak -> s
+ | Scontinue -> s
+ | Sswitch(e, s1) ->
+ {s with sdesc = Sswitch(transf_expr e, transf_stmt s1)}
+ | Slabeled(lbl, s1) ->
+ {s with sdesc = Slabeled(lbl, transf_stmt s1)}
+ | Sgoto lbl -> s
+ | Sreturn None -> s
+ | Sreturn(Some e) ->
+ let e = transf_expr e in
+ begin match optres with
+ | None ->
+ {s with sdesc = Sreturn(Some e)}
+ | Some dst ->
+ sseq s.sloc
+ (sassign s.sloc dst e)
+ {sdesc = Sreturn None; sloc = s.sloc}
+ end
+ | Sblock sl ->
+ {s with sdesc = Sblock(List.map transf_stmt sl)}
+ | Sdecl d ->
+ {s with sdesc = Sdecl(transf_decl env d)}
+
+in
+ transf_stmt body
+
+let transf_params loc env params =
+ let rec transf_prm = function
+ | [] ->
+ ([], [], sskip)
+ | (id, ty) :: params ->
+ let ty = transf_type env ty in
+ if is_composite_type env ty then begin
+ let id' = Env.fresh_ident id.name in
+ let ty' = TPtr(add_attributes_type [AConst] ty, []) in
+ let (params', decls, init) = transf_prm params in
+ ((id', ty') :: params',
+ (Storage_default, id, ty, None) :: decls,
+ sseq loc
+ (sassign loc {edesc = EVar id; etyp = ty}
+ {edesc = EUnop(Oderef, {edesc = EVar id'; etyp = ty'});
+ etyp = ty})
+ init)
+ end else begin
+ let (params', decls, init) = transf_prm params in
+ ((id, ty) :: params', decls, init)
+ end
+ in transf_prm params
+
+let transf_fundef env f =
+ reset_temps();
+ let ret = transf_type env f.fd_ret in
+ let (params, newdecls, init) = transf_params f.fd_body.sloc env f.fd_params in
+ let (ret1, params1, body1) =
+ if is_composite_type env ret then begin
+ let vres = Env.fresh_ident "_res" in
+ let tres = TPtr(ret, []) in
+ let eres = {edesc = EVar vres; etyp = tres} in
+ let eeres = {edesc = EUnop(Oderef, eres); etyp = ret} in
+ (TVoid [],
+ (vres, tres) :: params,
+ transf_funbody env f.fd_body (Some eeres))
+ end else
+ (ret, params, transf_funbody env f.fd_body None) in
+ let body2 = sseq body1.sloc init body1 in
+ let temps = get_temps() in
+ {f with fd_ret = ret1; fd_params = params1;
+ fd_locals = newdecls @ f.fd_locals @ temps; fd_body = body2}
+
+(* Composites *)
+
+let transf_composite env su id fl =
+ List.map (fun f -> {f with fld_typ = transf_type env f.fld_typ}) fl
+
+(* Entry point *)
+
+let program p =
+ Transform.program
+ ~decl:transf_decl
+ ~fundef:transf_fundef
+ ~composite:transf_composite
+ ~typedef:(fun env id ty -> transf_type env ty)
+ p
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+val program: C.program -> C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Generic program transformation *)
+
+open C
+open Cutil
+open Env
+
+(* Recording fresh temporaries *)
+
+let temporaries = ref ([]: decl list)
+
+let reset_temps () =
+ temporaries := []
+
+let new_temp_var ?(name = "t") ty =
+ let id = Env.fresh_ident name in
+ temporaries := (Storage_default, id, ty, None) :: !temporaries;
+ id
+
+let new_temp ?(name = "t") ty =
+ let id = new_temp_var ~name ty in
+ { edesc = EVar id; etyp = ty }
+
+let get_temps () =
+ let temps = !temporaries in
+ temporaries := [];
+ List.rev temps
+
+(* Generic transformation *)
+
+let program
+ ?(decl = fun env d -> d)
+ ?(fundef = fun env fd -> fd)
+ ?(composite = fun env su id fl -> fl)
+ ?(typedef = fun env id ty -> ty)
+ p =
+
+(* In all transformations of interest so far, the environment is used only
+ for its type definitions and struct/union definitions,
+ so we do not update it for other definitions. *)
+
+ let rec transf_globdecls env accu = function
+ | [] -> List.rev accu
+ | g :: gl ->
+ let (desc', env') =
+ match g.gdesc with
+ | Gdecl((sto, id, ty, init) as d) ->
+ (Gdecl(decl env d), Env.add_ident env id sto ty)
+ | Gfundef f ->
+ (Gfundef(fundef env f),
+ Env.add_ident env f.fd_name f.fd_storage (fundef_typ f))
+ | Gcompositedecl(su, id) ->
+ (Gcompositedecl(su, id),
+ Env.add_composite env id (composite_info_decl env su))
+ | Gcompositedef(su, id, fl) ->
+ (Gcompositedef(su, id, composite env su id fl),
+ Env.add_composite env id (composite_info_def env su fl))
+ | Gtypedef(id, ty) ->
+ (Gtypedef(id, typedef env id ty), Env.add_typedef env id ty)
+ | Genumdef _ as gd -> (gd, env)
+ | Gpragma _ as gd -> (gd, env)
+ in
+ transf_globdecls env' ({g with gdesc = desc'} :: accu) gl
+
+ in transf_globdecls (Builtins.environment()) [] p
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Generic program transformation *)
+
+val reset_temps : unit -> unit
+val new_temp_var : ?name:string -> C.typ -> C.ident
+val new_temp : ?name:string -> C.typ -> C.exp
+val get_temps : unit -> C.decl list
+
+val program :
+ ?decl:(Env.t -> C.decl -> C.decl) ->
+ ?fundef:(Env.t -> C.fundef -> C.fundef) ->
+ ?composite:(Env.t ->
+ C.struct_or_union -> C.ident -> C.field list -> C.field list) ->
+ ?typedef:(Env.t -> C.ident -> Env.typedef_info -> Env.typedef_info) ->
+ C.program ->
+ C.program
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Simplification of blocks and initializers within functions *)
+
+(* Assumes: nothing
+ Produces: unblocked code *)
+
+open C
+open Cutil
+open Errors
+
+(* Convert an initializer to a list of assignments.
+ Prepend those assignments to the given statement. *)
+
+let sdoseq loc e s =
+ sseq loc {sdesc = Sdo e; sloc = loc} s
+
+let rec local_initializer loc env path init k =
+ match init with
+ | Init_single e ->
+ sdoseq loc
+ { edesc = EBinop(Oassign, path, e, path.etyp); etyp = path.etyp }
+ k
+ | Init_array il ->
+ let ty_elt =
+ match unroll env path.etyp with
+ | TArray(ty_elt, _, _) -> ty_elt
+ | _ -> fatal_error "%aWrong type for array initializer"
+ formatloc loc in
+ let rec array_init pos = function
+ | [] -> k
+ | i :: il ->
+ local_initializer loc env
+ { edesc = EBinop(Oindex, path, intconst pos IInt, TPtr(ty_elt, []));
+ etyp = ty_elt }
+ i
+ (array_init (Int64.succ pos) il) in
+ array_init 0L il
+ | Init_struct(id, fil) ->
+ let field_init (fld, i) k =
+ local_initializer loc env
+ { edesc = EUnop(Odot fld.fld_name, path); etyp = fld.fld_typ }
+ i k in
+ List.fold_right field_init fil k
+ | Init_union(id, fld, i) ->
+ local_initializer loc env
+ { edesc = EUnop(Odot fld.fld_name, path); etyp = fld.fld_typ }
+ i k
+
+(* Record new variables to be locally defined *)
+
+let local_variables = ref ([]: decl list)
+
+(* Note: "const int x = y - 1;" is legal, but we turn it into
+ "const int x; x = y - 1;", which is not. Therefore, remove
+ top-level 'const' attribute. Also remove it on element type of
+ array type. *)
+
+let remove_const env ty = remove_attributes_type env [AConst] ty
+
+(* Process a variable declaration.
+ The variable is entered in [local_variables].
+ The initializer, if any, is converted into assignments and
+ prepended to [k]. *)
+
+let process_decl loc env (sto, id, ty, optinit) k =
+ let ty' = remove_const env ty in
+ local_variables := (sto, id, ty', None) :: !local_variables;
+ match optinit with
+ | None -> k
+ | Some init ->
+ local_initializer loc env { edesc = EVar id; etyp = ty' } init k
+
+(* Simplification of blocks within a statement *)
+
+let rec unblock_stmt env s =
+ match s.sdesc with
+ | Sskip -> s
+ | Sdo e -> s
+ | Sseq(s1, s2) ->
+ {s with sdesc = Sseq(unblock_stmt env s1, unblock_stmt env s2)}
+ | Sif(e, s1, s2) ->
+ {s with sdesc = Sif(e, unblock_stmt env s1, unblock_stmt env s2)}
+ | Swhile(e, s1) ->
+ {s with sdesc = Swhile(e, unblock_stmt env s1)}
+ | Sdowhile(s1, e) ->
+ {s with sdesc = Sdowhile(unblock_stmt env s1, e)}
+ | Sfor(s1, e, s2, s3) ->
+ {s with sdesc = Sfor(unblock_stmt env s1, e, unblock_stmt env s2, unblock_stmt env s3)}
+ | Sbreak -> s
+ | Scontinue -> s
+ | Sswitch(e, s1) ->
+ {s with sdesc = Sswitch(e, unblock_stmt env s1)}
+ | Slabeled(lbl, s1) ->
+ {s with sdesc = Slabeled(lbl, unblock_stmt env s1)}
+ | Sgoto lbl -> s
+ | Sreturn opte -> s
+ | Sblock sl -> unblock_block env sl
+ | Sdecl d -> assert false
+
+and unblock_block env = function
+ | [] -> sskip
+ | {sdesc = Sdecl d; sloc = loc} :: sl ->
+ process_decl loc env d (unblock_block env sl)
+ | s :: sl ->
+ sseq s.sloc (unblock_stmt env s) (unblock_block env sl)
+
+(* Simplification of blocks within a function *)
+
+let unblock_fundef env f =
+ local_variables := [];
+ let body = unblock_stmt env f.fd_body in
+ let decls = !local_variables in
+ local_variables := [];
+ { f with fd_locals = f.fd_locals @ decls; fd_body = body }
+
+(* Entry point *)
+
+let program p =
+ Transform.program ~fundef:unblock_fundef p
--- /dev/null
+(* *********************************************************************)
+(* *)
+(* The Compcert verified compiler *)
+(* *)
+(* Xavier Leroy, INRIA Paris-Rocquencourt *)
+(* *)
+(* Copyright Institut National de Recherche en Informatique et en *)
+(* Automatique. All rights reserved. This file is distributed *)
+(* under the terms of the GNU General Public License as published by *)
+(* the Free Software Foundation, either version 2 of the License, or *)
+(* (at your option) any later version. This file is also distributed *)
+(* under the terms of the INRIA Non-Commercial License Agreement. *)
+(* *)
+(* *********************************************************************)
+
+(* Simplification of blocks and initializers within functions *)
+
+val program: C.program -> C.program
--- /dev/null
+/* *********************************************************************/
+/* */
+/* The Compcert verified compiler */
+/* */
+/* Xavier Leroy, INRIA Paris-Rocquencourt */
+/* */
+/* Copyright Institut National de Recherche en Informatique et en */
+/* Automatique. All rights reserved. This file is distributed */
+/* under the terms of the GNU General Public License as published by */
+/* the Free Software Foundation, either version 2 of the License, or */
+/* (at your option) any later version. This file is also distributed */
+/* under the terms of the INRIA Non-Commercial License Agreement. */
+/* */
+/* *********************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+
+value cparser_int64_unsigned_to_float(value v)
+{
+ return caml_copy_double((double)((uint64) Int64_val(v)));
+}
+
+value cparser_int64_unsigned_div(value v1, value v2)
+{
+ return caml_copy_int64((uint64) Int64_val(v1) / (uint64) Int64_val(v2));
+}
+
+value cparser_int64_unsigned_mod(value v1, value v2)
+{
+ return caml_copy_int64((uint64) Int64_val(v1) % (uint64) Int64_val(v2));
+}
+
+value cparser_int64_unsigned_compare(value v1, value v2)
+{
+ uint64 n1 = (uint64) Int64_val(v1);
+ uint64 n2 = (uint64) Int64_val(v2);
+ if (n1 < n2) return Val_int(-1);
+ if (n1 > n2) return Val_int(1);
+ return Val_int(0);
+}
+
--- /dev/null
+#!/bin/sh
+
+TGT=acc-trusted-0.1
+
+rm -rf $TGT
+svn export . $TGT
+rm $TGT/cparser
+svn export `readlink cparser` $TGT/cparser
+tar -czf $TGT.tar.gz $TGT
+rm -rf $TGT
rm -f set_adt.ml set_adt.mli
# Uses a GNU sed extension
for i in `ls *.ml untrusted/*.ml`; do basename $i | sed -e 's/\(.\)\(.*\)\.ml/\U\1\E\2/'; done > extracted.mlpack
-ocamlbuild -Is untrusted -tag debug extracted.cmo
+for i in `ls *.ml untrusted/*.ml`; do echo "<"${i%%.ml}".cmx>: for-pack(Extracted)"; done > _tags
+ocamlbuild -Is untrusted -tag debug extracted.cmo extracted.cmx
projects / pkg-cerco / acc-trusted.git / commitdiff