diff options
90 files changed, 11165 insertions, 105 deletions
@@ -25,9 +25,12 @@ option) any later version: cfrontend/PrintCsyntax.ml lib/Integers.v cfrontend/Csem.v lib/Maps.v cfrontend/Csyntax.v lib/Parmov.v - common/AST.v runtime/calloc.c - common/Errors.v runtime/stdio.c - common/Events.v runtime/stdio.h + common/AST.v lib/Camlcoq.ml + common/Errors.v + common/Events.v + all files in the runtime/ directory + all files in the cparser/ directory + (except those listed below which are under a BSD license) A copy of the GNU General Public License version 2 is included below. @@ -37,12 +40,14 @@ files are free software and can be used both in commercial and non-commercial contexts, subject to the terms of the GNU General Public License. -This distribution includes a modified copy of the CIL library. -The CIL library is Copyright 2001-2005 George C. Necula, Scott McPeak, -Wes Weimer and Ben Liblit. The modifications are Copyright 2006, -2007, 2008, 2009 Institut National de Recherche en Informatique et en -Automatique. The CIL library and the modifications are distributed -under the terms of the BSD license, included below. +Finally, the following files are taken from the CIL library: + cparser/Cabs.ml + cparser/Lexer.mli + cparser/Lexer.mll + cparser/Parser.mly +These files are Copyright 2001-2005 George C. Necula, Scott McPeak, +Wes Weimer and Ben Liblit, and are distributed under the terms of the +BSD license, included below. ---------------------------------------------------------------------- @@ -25,10 +25,7 @@ OCAMLBUILD=ocamlbuild OCB_OPTIONS=\ -no-hygiene \ -no-links \ - -I extraction $(INCLUDES) \ - -cflags -I,`pwd`/cil/obj/$(ARCHOS) \ - -lflags -I,`pwd`/cil/obj/$(ARCHOS) \ - -libs unix,str,cil + -I extraction $(INCLUDES) VPATH=$(DIRS) GPATH=$(DIRS) @@ -89,9 +86,6 @@ extraction: $(COQEXEC) extraction/extraction.v cd extraction && ./fixextract -cil: - $(MAKE) -j1 -C cil - ccomp: driver/Configuration.ml $(OCAMLBUILD) $(OCB_OPTIONS) Driver.native \ && rm -f ccomp && ln -s _build/driver/Driver.native ccomp @@ -111,7 +105,6 @@ runtime: all: $(MAKE) proof - $(MAKE) cil $(MAKE) extraction $(MAKE) ccomp $(MAKE) runtime @@ -178,7 +171,6 @@ clean: distclean: $(MAKE) clean - rm -rf cil rm -f Makefile.config include .depend @@ -0,0 +1,2 @@ +<cparser/*.cmx>: for-pack(Cparser) +<driver/Driver.*{byte,native}>: use_unix,use_str,use_Cparser diff --git a/backend/RTLgenaux.ml b/backend/RTLgenaux.ml index 1f457f3..82cb300 100644 --- a/backend/RTLgenaux.ml +++ b/backend/RTLgenaux.ml @@ -99,8 +99,10 @@ let dense_enough (numcases: int) (minkey: int64) (maxkey: int64) = let compile_switch default table = let (tbl, keys) = normalize_table table in - let minkey = uint64_of_coqint (IntSet.min_elt keys) - and maxkey = uint64_of_coqint (IntSet.max_elt keys) in - if dense_enough (List.length tbl) minkey maxkey - then compile_switch_as_jumptable default tbl minkey maxkey - else compile_switch_as_tree default tbl + if IntSet.is_empty keys then CTaction default else begin + let minkey = uint64_of_coqint (IntSet.min_elt keys) + and maxkey = uint64_of_coqint (IntSet.max_elt keys) in + if dense_enough (List.length tbl) minkey maxkey + then compile_switch_as_jumptable default tbl minkey maxkey + else compile_switch_as_tree default tbl + end diff --git a/cfrontend/C2Clight.ml b/cfrontend/C2Clight.ml new file mode 100644 index 0000000..fcb0c7c --- /dev/null +++ b/cfrontend/C2Clight.ml @@ -0,0 +1,741 @@ +open Printf + +open Cparser +open Cparser.C +open Cparser.Env + +open Camlcoq +open AST +open Csyntax + +(** Record the declarations of global variables and associate them + with the corresponding atom. *) + +let decl_atom : (AST.ident, Env.t * C.decl) Hashtbl.t = Hashtbl.create 103 + +(** Hooks -- overriden in machine-dependent CPragmas module *) + +let process_pragma_hook = ref (fun (s: string) -> false) +let define_variable_hook = ref (fun (id: ident) (d: C.decl) -> ()) +let define_function_hook = ref (fun (id: ident) (d: C.decl) -> ()) +let define_stringlit_hook = ref (fun (id: ident) -> ()) + +(** ** Error handling *) + +let currentLocation = ref Cutil.no_loc + +let updateLoc l = currentLocation := l + +let numErrors = ref 0 + +let error msg = + incr numErrors; + eprintf "%aError: %s\n" Cutil.printloc !currentLocation msg + +let unsupported msg = + incr numErrors; + eprintf "%aUnsupported feature: %s\n" Cutil.printloc !currentLocation msg + +let warning msg = + eprintf "%aWarning: %s\n" Cutil.printloc !currentLocation msg + + +(** ** Functions used to handle string literals *) + +let stringNum = ref 0 (* number of next global for string literals *) +let stringTable = Hashtbl.create 47 + +let name_for_string_literal env s = + try + Hashtbl.find stringTable s + with Not_found -> + incr stringNum; + let name = Printf.sprintf "__stringlit_%d" !stringNum in + let id = intern_string name in + Hashtbl.add decl_atom id + (env, (C.Storage_static, + Env.fresh_ident name, + C.TPtr(C.TInt(C.IChar,[C.AConst]),[]), + None)); + !define_stringlit_hook id; + Hashtbl.add stringTable s id; + id + +let typeStringLiteral s = + Tarray(Tint(I8, Unsigned), z_of_camlint(Int32.of_int(String.length s + 1))) + +let global_for_string s id = + let init = ref [] in + let add_char c = + init := + AST.Init_int8(coqint_of_camlint(Int32.of_int(Char.code c))) + :: !init in + add_char '\000'; + for i = String.length s - 1 downto 0 do add_char s.[i] done; + Datatypes.Coq_pair(Datatypes.Coq_pair(id, !init), typeStringLiteral s) + +let globals_for_strings globs = + Hashtbl.fold + (fun s id l -> global_for_string s id :: l) + stringTable globs + +(** ** Handling of stubs for variadic functions *) + +let stub_function_table = Hashtbl.create 47 + +let register_stub_function name tres targs = + let rec letters_of_type = function + | Tnil -> [] + | Tcons(Tfloat _, tl) -> "f" :: letters_of_type tl + | Tcons(_, tl) -> "i" :: letters_of_type tl in + let stub_name = + name ^ "$" ^ String.concat "" (letters_of_type targs) in + try + (stub_name, Hashtbl.find stub_function_table stub_name) + with Not_found -> + let rec types_of_types = function + | Tnil -> Tnil + | Tcons(Tfloat _, tl) -> Tcons(Tfloat F64, types_of_types tl) + | Tcons(_, tl) -> Tcons(Tpointer Tvoid, types_of_types tl) in + let stub_type = Tfunction (types_of_types targs, tres) in + Hashtbl.add stub_function_table stub_name stub_type; + (stub_name, stub_type) + +let declare_stub_function stub_name stub_type = + match stub_type with + | Tfunction(targs, tres) -> + Datatypes.Coq_pair(intern_string stub_name, + External(intern_string stub_name, targs, tres)) + | _ -> assert false + +let declare_stub_functions k = + Hashtbl.fold (fun n i k -> declare_stub_function n i :: k) + stub_function_table k + +(** ** Translation functions *) + +(** Constants *) + +let convertInt n = coqint_of_camlint(Int64.to_int32 n) + +(** Types *) + +let convertIkind = function + | C.IBool -> unsupported "'_Bool' type"; (Unsigned, I8) + | C.IChar -> (Unsigned, I8) + | C.ISChar -> (Signed, I8) + | C.IUChar -> (Unsigned, I8) + | C.IInt -> (Signed, I32) + | C.IUInt -> (Unsigned, I32) + | C.IShort -> (Signed, I16) + | C.IUShort -> (Unsigned, I16) + | C.ILong -> (Signed, I32) + | C.IULong -> (Unsigned, I32) + | C.ILongLong -> + if not !Clflags.option_flonglong then unsupported "'long long' type"; + (Signed, I32) + | C.IULongLong -> + if not !Clflags.option_flonglong then unsupported "'unsigned long long' type"; + (Unsigned, I32) + +let convertFkind = function + | C.FFloat -> F32 + | C.FDouble -> F64 + | C.FLongDouble -> + if not !Clflags.option_flonglong then unsupported "'long double' type"; + F64 + +let convertTyp env t = + + let rec convertTyp seen t = + match Cutil.unroll env t with + | C.TVoid a -> Tvoid + | C.TInt(ik, a) -> + let (sg, sz) = convertIkind ik in Tint(sz, sg) + | C.TFloat(fk, a) -> + Tfloat(convertFkind fk) + | C.TPtr(C.TStruct(id, _), _) when List.mem id seen -> + Tcomp_ptr(intern_string ("struct " ^ id.name)) + | C.TPtr(C.TUnion(id, _), _) when List.mem id seen -> + Tcomp_ptr(intern_string ("union " ^ id.name)) + | C.TPtr(ty, a) -> + Tpointer(convertTyp seen ty) + | C.TArray(ty, None, a) -> + warning "array type of unspecified size"; + Tarray(convertTyp seen ty, coqint_of_camlint 0l) + | C.TArray(ty, Some sz, a) -> + Tarray(convertTyp seen ty, convertInt sz) + | C.TFun(tres, targs, va, a) -> + if va then unsupported "variadic function type"; + if Cutil.is_composite_type env tres then + unsupported "return type is a struct or union"; + Tfunction(begin match targs with + | None -> warning "un-prototyped function type"; Tnil + | Some tl -> convertParams seen tl + end, + convertTyp seen tres) + | C.TNamed _ -> + assert false + | C.TStruct(id, a) -> + let flds = + try + convertFields (id :: seen) (Env.find_struct env id) + with Env.Error e -> + error (Env.error_message e); Fnil in + Tstruct(intern_string("struct " ^ id.name), flds) + | C.TUnion(id, a) -> + let flds = + try + convertFields (id :: seen) (Env.find_union env id) + with Env.Error e -> + error (Env.error_message e); Fnil in + Tunion(intern_string("union " ^ id.name), flds) + + and convertParams seen = function + | [] -> Tnil + | (id, ty) :: rem -> + if Cutil.is_composite_type env ty then + unsupported "function parameter of struct or union type"; + Tcons(convertTyp seen ty, convertParams seen rem) + + and convertFields seen ci = + convertFieldList seen ci.Env.ci_members + + and convertFieldList seen = function + | [] -> Fnil + | f :: fl -> + if f.fld_bitfield <> None then + unsupported "bit field in struct or union"; + Fcons(intern_string f.fld_name, convertTyp seen f.fld_typ, + convertFieldList seen fl) + + in convertTyp [] t + +let rec convertTypList env = function + | [] -> Tnil + | t1 :: tl -> Tcons(convertTyp env t1, convertTypList env tl) + +(** Expressions *) + +let ezero = Expr(Econst_int(coqint_of_camlint 0l), Tint(I32, Signed)) + +let rec convertExpr env e = + let ty = convertTyp env e.etyp in + match e.edesc with + | C.EConst(C.CInt(i, _, _)) -> + Expr(Econst_int(convertInt i), ty) + | C.EConst(C.CFloat(f, _, _)) -> + Expr(Econst_float f, ty) + | C.EConst(C.CStr s) -> + Expr(Evar(name_for_string_literal env s), typeStringLiteral s) + | C.EConst(C.CWStr s) -> + unsupported "wide string literal"; ezero + | C.EConst(C.CEnum(id, i)) -> + Expr(Econst_int(convertInt i), ty) + + | C.ESizeof ty1 -> + Expr(Esizeof(convertTyp env ty1), ty) + | C.EVar id -> + Expr(Evar(intern_string id.name), ty) + + | C.EUnop(C.Oderef, e1) -> + Expr(Ederef(convertExpr env e1), ty) + | C.EUnop(C.Oaddrof, e1) -> + Expr(Eaddrof(convertExpr env e1), ty) + | C.EUnop(C.Odot id, e1) -> + Expr(Efield(convertExpr env e1, intern_string id), ty) + | C.EUnop(C.Oarrow id, e1) -> + let e1' = convertExpr env e1 in + let ty1 = + match typeof e1' with + | Tpointer t -> t + | _ -> error ("wrong type for ->" ^ id ^ " access"); Tvoid in + Expr(Efield(Expr(Ederef(convertExpr env e1), ty1), + intern_string id), ty) + | C.EUnop(C.Oplus, e1) -> + convertExpr env e1 + | C.EUnop(C.Ominus, e1) -> + Expr(Eunop(Oneg, convertExpr env e1), ty) + | C.EUnop(C.Olognot, e1) -> + Expr(Eunop(Onotbool, convertExpr env e1), ty) + | C.EUnop(C.Onot, e1) -> + Expr(Eunop(Onotint, convertExpr env e1), ty) + | C.EUnop(_, _) -> + unsupported "pre/post increment/decrement operator"; ezero + + | C.EBinop(C.Oindex, e1, e2, _) -> + Expr(Ederef(Expr(Ebinop(Oadd, convertExpr env e1, convertExpr env e2), + Tpointer ty)), ty) + | C.EBinop(C.Ologand, e1, e2, _) -> + Expr(Eandbool(convertExpr env e1, convertExpr env e2), ty) + | C.EBinop(C.Ologor, e1, e2, _) -> + Expr(Eorbool(convertExpr env e1, convertExpr env e2), ty) + | C.EBinop(op, e1, e2, _) -> + let op' = + match op with + | C.Oadd -> Oadd + | C.Osub -> Osub + | C.Omul -> Omul + | C.Odiv -> Odiv + | C.Omod -> Omod + | C.Oand -> Oand + | C.Oor -> Oor + | C.Oxor -> Oxor + | C.Oshl -> Oshl + | C.Oshr -> Oshr + | C.Oeq -> Oeq + | C.One -> One + | C.Olt -> Olt + | C.Ogt -> Ogt + | C.Ole -> Ole + | C.Oge -> Oge + | C.Ocomma -> unsupported "sequence operator"; Oadd + | _ -> unsupported "assignment operator"; Oadd in + Expr(Ebinop(op', convertExpr env e1, convertExpr env e2), ty) + | C.EConditional(e1, e2, e3) -> + Expr(Econdition(convertExpr env e1, convertExpr env e2, convertExpr env e3), ty) + | C.ECast(ty1, e1) -> + Expr(Ecast(convertTyp env ty1, convertExpr env e1), ty) + | C.ECall _ -> + unsupported "function call within expression"; ezero + +(* Function calls *) + +let rec projFunType env ty = + match Cutil.unroll env ty with + | TFun(res, args, vararg, attr) -> Some(res, vararg) + | TPtr(ty', attr) -> projFunType env ty' + | _ -> None + +let convertFuncall env lhs fn args = + let lhs' = + match lhs with None -> None | Some e -> Some(convertExpr env e) in + match projFunType env fn.etyp with + | None -> + error "wrong type for function part of a call"; Sskip + | Some(res, false) -> + (* Non-variadic function *) + Scall(lhs', convertExpr env fn, List.map (convertExpr env) args) + | Some(res, true) -> + (* Variadic function: generate a call to a stub function with + the appropriate number and types of arguments. Works only if + the function expression e is a global variable. *) + let fun_name = + match fn with + | {edesc = C.EVar id} when !Clflags.option_fvararg_calls -> + warning "emulating call to variadic function"; + id.name + | _ -> + unsupported "call to variadic function"; + "" in + let targs = convertTypList env (List.map (fun e -> e.etyp) args) in + let tres = convertTyp env res in + let (stub_fun_name, stub_fun_typ) = + register_stub_function fun_name tres targs in + Scall(lhs', + Expr(Evar(intern_string stub_fun_name), stub_fun_typ), + List.map (convertExpr env) args) + +(* Toplevel expression, argument of an Sdo *) + +let convertTopExpr env e = + match e.edesc with + | C.EBinop(C.Oassign, lhs, {edesc = C.ECall(fn, args)}, _) -> + convertFuncall env (Some lhs) fn args + | C.EBinop(C.Oassign, lhs, rhs, _) -> + Sassign(convertExpr env lhs, convertExpr env rhs) + | C.ECall(fn, args) -> + convertFuncall env None fn args + | _ -> + unsupported "illegal toplevel expression"; Sskip + +(* Separate the cases of a switch statement body *) + +type switchlabel = + | Case of C.exp + | Default + +type switchbody = + | Label of switchlabel + | Stmt of C.stmt + +let rec flattenSwitch = function + | {sdesc = C.Sseq(s1, s2)} -> + flattenSwitch s1 @ flattenSwitch s2 + | {sdesc = C.Slabeled(C.Scase e, s1)} -> + Label(Case e) :: flattenSwitch s1 + | {sdesc = C.Slabeled(C.Sdefault, s1)} -> + Label Default :: flattenSwitch s1 + | s -> + [Stmt s] + +let rec groupSwitch = function + | [] -> + (Cutil.sskip, []) + | Label case :: rem -> + let (fst, cases) = groupSwitch rem in + (Cutil.sskip, (case, fst) :: cases) + | Stmt s :: rem -> + let (fst, cases) = groupSwitch rem in + (Cutil.sseq s.sloc s fst, cases) + +(* Statement *) + +let rec convertStmt env s = + updateLoc s.sloc; + match s.sdesc with + | C.Sskip -> + Sskip + | C.Sdo e -> + convertTopExpr env e + | C.Sseq(s1, s2) -> + Ssequence(convertStmt env s1, convertStmt env s2) + | C.Sif(e, s1, s2) -> + Sifthenelse(convertExpr env e, convertStmt env s1, convertStmt env s2) + | C.Swhile(e, s1) -> + Swhile(convertExpr env e, convertStmt env s1) + | C.Sdowhile(s1, e) -> + Sdowhile(convertExpr env e, convertStmt env s1) + | C.Sfor(s1, e, s2, s3) -> + Sfor(convertStmt env s1, convertExpr env e, convertStmt env s2, + convertStmt env s3) + | C.Sbreak -> + Sbreak + | C.Scontinue -> + Scontinue + | C.Sswitch(e, s1) -> + let (init, cases) = groupSwitch (flattenSwitch s1) in + if cases = [] then + unsupported "ill-formed 'switch' statement"; + if init.sdesc <> C.Sskip then + warning "ignored code at beginning of 'switch'"; + Sswitch(convertExpr env e, convertSwitch env cases) + | C.Slabeled(C.Slabel lbl, s1) -> + Slabel(intern_string lbl, convertStmt env s1) + | C.Slabeled(C.Scase _, _) -> + unsupported "'case' outside of 'switch'"; Sskip + | C.Slabeled(C.Sdefault, _) -> + unsupported "'default' outside of 'switch'"; Sskip + | C.Sgoto lbl -> + Sgoto(intern_string lbl) + | C.Sreturn None -> + Sreturn None + | C.Sreturn(Some e) -> + Sreturn(Some(convertExpr env e)) + | C.Sblock _ -> + unsupported "nested blocks"; Sskip + | C.Sdecl _ -> + unsupported "inner declarations"; Sskip + +and convertSwitch env = function + | [] -> + LSdefault Sskip + | [Default, s] -> + LSdefault (convertStmt env s) + | (Default, s) :: _ -> + updateLoc s.sloc; + unsupported "'default' case must occur last"; + LSdefault Sskip + | (Case e, s) :: rem -> + updateLoc s.sloc; + let v = + match Ceval.integer_expr env e with + | None -> unsupported "'case' label is not a compile-time integer"; 0L + | Some v -> v in + LScase(convertInt v, + convertStmt env s, + convertSwitch env rem) + +(** Function definitions *) + +let convertFundef env fd = + if Cutil.is_composite_type env fd.fd_ret then + unsupported "function returning a struct or union"; + let ret = + convertTyp env fd.fd_ret in + let params = + List.map + (fun (id, ty) -> + if Cutil.is_composite_type env ty then + unsupported "function parameter of struct or union type"; + Datatypes.Coq_pair(intern_string id.name, convertTyp env ty)) + fd.fd_params in + let vars = + List.map + (fun (sto, id, ty, init) -> + if sto = Storage_extern || sto = Storage_static then + unsupported "'static' or 'extern' local variable"; + if init <> None then + unsupported "initialized local variable"; + Datatypes.Coq_pair(intern_string id.name, convertTyp env ty)) + fd.fd_locals in + let body' = convertStmt env fd.fd_body in + let id' = intern_string fd.fd_name.name in + let decl = + (fd.fd_storage, fd.fd_name, Cutil.fundef_typ fd, None) in + Hashtbl.add decl_atom id' (env, decl); + !define_function_hook id' decl; + Datatypes.Coq_pair(id', + Internal {fn_return = ret; fn_params = params; + fn_vars = vars; fn_body = body'}) + +(** External function declaration *) + +let convertFundecl env (sto, id, ty, optinit) = + match convertTyp env ty with + | Tfunction(args, res) -> + let id' = intern_string id.name in + Datatypes.Coq_pair(id', External(id', args, res)) + | _ -> + assert false + +(** Initializers *) + +let init_data_of_string s = + let id = ref [] in + let enter_char c = + let n = coqint_of_camlint(Int32.of_int(Char.code c)) in + id := Init_int8 n :: !id in + enter_char '\000'; + for i = String.length s - 1 downto 0 do enter_char s.[i] done; + !id + +let convertInit env ty init = + + let k = ref [] + and pos = ref 0 in + let emit size datum = + k := datum :: !k; + pos := !pos + size in + let emit_space size = + emit size (Init_space (z_of_camlint (Int32.of_int size))) in + let align size = + let n = !pos land (size - 1) in + if n > 0 then emit_space (size - n) in + let check_align size = + assert (!pos land (size - 1) = 0) in + + let rec reduceInitExpr = function + | { edesc = C.EVar id; etyp = ty } -> + begin match Cutil.unroll env ty with + | C.TArray _ | C.TFun _ -> Some id + | _ -> None + end + | {edesc = C.EUnop(C.Oaddrof, {edesc = C.EVar id})} -> Some id + | {edesc = C.ECast(ty, e)} -> reduceInitExpr e + | _ -> None in + + let rec cvtInit ty = function + | Init_single e -> + begin match reduceInitExpr e with + | Some id -> + check_align 4; + emit 4 (Init_addrof(intern_string id.name, coqint_of_camlint 0l)) + | None -> + match Ceval.constant_expr env ty e with + | Some(C.CInt(v, ik, _)) -> + begin match convertIkind ik with + | (_, I8) -> + emit 1 (Init_int8(convertInt v)) + | (_, I16) -> + check_align 2; + emit 2 (Init_int16(convertInt v)) + | (_, I32) -> + check_align 4; + emit 4 (Init_int32(convertInt v)) + end + | Some(C.CFloat(v, fk, _)) -> + begin match convertFkind fk with + | F32 -> + check_align 4; + emit 4 (Init_float32 v) + | F64 -> + check_align 8; + emit 8 (Init_float64 v) + end + | Some(C.CStr s) -> + check_align 4; + let id = name_for_string_literal env s in + emit 4 (Init_addrof(id, coqint_of_camlint 0l)) + | Some(C.CWStr _) -> + unsupported "wide character strings" + | Some(C.CEnum _) -> + error "enum tag after constant folding" + | None -> + error "initializer is not a compile-time constant" + end + | Init_array il -> + let ty_elt = + match Cutil.unroll env ty with + | C.TArray(t, _, _) -> t + | _ -> error "array type expected in initializer"; C.TVoid [] in + List.iter (cvtInit ty_elt) il + | Init_struct(_, flds) -> + cvtPadToSizeof ty (fun () -> List.iter cvtFieldInit flds) + | Init_union(_, fld, i) -> + cvtPadToSizeof ty (fun () -> cvtFieldInit (fld,i)) + + and cvtFieldInit (fld, i) = + let ty' = convertTyp env fld.fld_typ in + let al = Int32.to_int (camlint_of_z (Csyntax.alignof ty')) in + align al; + cvtInit fld.fld_typ i + + and cvtPadToSizeof ty fn = + let ty' = convertTyp env ty in + let sz = Int32.to_int (camlint_of_z (Csyntax.sizeof ty')) in + let pos0 = !pos in + fn(); + let pos1 = !pos in + assert (pos1 <= pos0 + sz); + if pos1 < pos0 + sz then emit_space (pos0 + sz - pos1) + + in cvtInit ty init; List.rev !k + +(** Global variable *) + +let convertGlobvar env (sto, id, ty, optinit as decl) = + let id' = intern_string id.name in + let ty' = convertTyp env ty in + let init' = + match optinit with + | None -> + if sto = C.Storage_extern then [] else [Init_space(Csyntax.sizeof ty')] + | Some i -> + convertInit env ty i in + Hashtbl.add decl_atom id' (env, decl); + !define_variable_hook id' decl; + Datatypes.Coq_pair(Datatypes.Coq_pair(id', init'), ty') + +(** Convert a list of global declarations. + Result is a pair [(funs, vars)] where [funs] are + the function definitions (internal and external) + and [vars] the variable declarations. *) + +let rec convertGlobdecls env funs vars gl = + match gl with + | [] -> (List.rev funs, List.rev vars) + | g :: gl' -> + updateLoc g.gloc; + match g.gdesc with + | C.Gdecl((sto, id, ty, optinit) as d) -> + (* Prototyped functions become external declarations. + Variadic functions are skipped. + Other types become variable declarations. *) + begin match Cutil.unroll env ty with + | TFun(_, Some _, false, _) -> + convertGlobdecls env (convertFundecl env d :: funs) vars gl' + | TFun(_, None, false, _) -> + error "function declaration without prototype"; + convertGlobdecls env funs vars gl' + | TFun(_, _, true, _) -> + convertGlobdecls env funs vars gl' + | _ -> + convertGlobdecls env funs (convertGlobvar env d :: vars) gl' + end + | C.Gfundef fd -> + convertGlobdecls env (convertFundef env fd :: funs) vars gl' + | C.Gcompositedecl _ | C.Gcompositedef _ + | C.Gtypedef _ | C.Genumdef _ -> + (* typedefs are unrolled, structs are expanded inline, and + enum tags are folded. So we just skip their declarations. *) + convertGlobdecls env funs vars gl' + | C.Gpragma s -> + if not (!process_pragma_hook s) then + warning ("'#pragma " ^ s ^ "' directive ignored"); + convertGlobdecls env funs vars gl' + +(** Build environment of typedefs and structs *) + +let rec translEnv env = function + | [] -> env + | g :: gl -> + let env' = + match g.gdesc with + | C.Gcompositedecl(su, id) -> + Env.add_composite env id + {ci_kind = su; ci_incomplete = true; ci_members = []} + | C.Gcompositedef(su, id, fld) -> + Env.add_composite env id + {ci_kind = su; ci_incomplete = false; ci_members = fld} + | C.Gtypedef(id, ty) -> + Env.add_typedef env id ty + | _ -> + env in + translEnv env' gl + +(** Eliminate forward declarations of globals that are defined later. *) + +module IdentSet = Set.Make(struct type t = C.ident let compare = compare end) + +let cleanupGlobals p = + + let rec clean defs accu = function + | [] -> accu + | g :: gl -> + updateLoc g.gloc; + match g.gdesc with + | C.Gdecl(sto, id, ty, None) -> + if IdentSet.mem id defs + then clean defs accu gl + else clean (IdentSet.add id defs) (g :: accu) gl + | C.Gdecl(_, id, ty, _) -> + if IdentSet.mem id defs then + error ("multiple definitions of " ^ id.name); + clean (IdentSet.add id defs) (g :: accu) gl + | C.Gfundef fd -> + if IdentSet.mem fd.fd_name defs then + error ("multiple definitions of " ^ fd.fd_name.name); + clean (IdentSet.add fd.fd_name defs) (g :: accu) gl + | _ -> + clean defs (g :: accu) gl + + in clean IdentSet.empty [] (List.rev p) + +(** Convert a [C.program] into a [Csyntax.program] *) + +let convertProgram p = + numErrors := 0; + stringNum := 0; + Hashtbl.clear decl_atom; + Hashtbl.clear stringTable; + Hashtbl.clear stub_function_table; + try + let (funs1, vars1) = + convertGlobdecls (translEnv Env.empty p) [] [] (cleanupGlobals p) in + let funs2 = declare_stub_functions funs1 in + let vars2 = globals_for_strings vars1 in + if !numErrors > 0 + then None + else Some { AST.prog_funct = funs2; + AST.prog_vars = vars2; + AST.prog_main = intern_string "main" } + with Env.Error msg -> + error (Env.error_message msg); None + +(** ** Extracting information about global variables from their atom *) + +let type_is_readonly env t = + let a = Cutil.attributes_of_type env t in + if List.mem C.AVolatile a then false else + if List.mem C.AConst a then true else + match Cutil.unroll env t with + | C.TArray(ty, _, _) -> + let a' = Cutil.attributes_of_type env ty in + List.mem C.AConst a' && not (List.mem C.AVolatile a') + | _ -> + false + +let atom_is_static a = + try + let (env, (sto, id, ty, init)) = Hashtbl.find decl_atom a in + sto = C.Storage_static + with Not_found -> + false + +let atom_is_readonly a = + try + let (env, (sto, id, ty, init)) = Hashtbl.find decl_atom a in + type_is_readonly env ty + with Not_found -> + false diff --git a/cfrontend/Cparser.mllib b/cfrontend/Cparser.mllib new file mode 100644 index 0000000..e942137 --- /dev/null +++ b/cfrontend/Cparser.mllib @@ -0,0 +1 @@ +Cparser diff --git a/cfrontend/Cparser.mlpack b/cfrontend/Cparser.mlpack new file mode 100644 index 0000000..410d7b2 --- /dev/null +++ b/cfrontend/Cparser.mlpack @@ -0,0 +1,25 @@ +cparser/C +cparser/Errors +cparser/Cabs +cparser/Cabshelper +cparser/Parse_aux +cparser/Parser +cparser/Lexer +cparser/Machine +cparser/Env +cparser/Cprint +cparser/Cutil +cparser/Ceval +cparser/Cleanup +cparser/Builtins +cparser/Elab +cparser/Rename +cparser/Transform +cparser/Unblock +cparser/SimplExpr +cparser/AddCasts +cparser/StructByValue +cparser/StructAssign +cparser/Bitfields +cparser/Parse + diff --git a/cfrontend/libCparser.clib b/cfrontend/libCparser.clib new file mode 100644 index 0000000..1b55150 --- /dev/null +++ b/cfrontend/libCparser.clib @@ -0,0 +1 @@ +cparser/uint64.o diff --git a/cparser/.depend b/cparser/.depend new file mode 100644 index 0000000..d5c86cf --- /dev/null +++ b/cparser/.depend @@ -0,0 +1,82 @@ +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: +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 +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 Cprint.cmi +Main.cmx: Parse.cmx Cprint.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 +Scoping.cmo: +Scoping.cmx: +SimplExpr.cmo: Transform.cmi Cutil.cmi C.cmi SimplExpr.cmi +SimplExpr.cmx: Transform.cmx Cutil.cmx C.cmi SimplExpr.cmi +SimplifyStrict.cmo: Env.cmi Cutil.cmi C.cmi +SimplifyStrict.cmx: Env.cmx Cutil.cmx C.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 diff --git a/cparser/AddCasts.ml b/cparser/AddCasts.ml new file mode 100644 index 0000000..5ad5c63 --- /dev/null +++ b/cparser/AddCasts.ml @@ -0,0 +1,242 @@ +(* *********************************************************************) +(* *) +(* 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) -> + { edesc = + EConditional(add_expr env e1, add_expr env e2, add_expr env e3); + 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 s = + match s.sdesc with + | Sskip -> s + | Sdo e -> add_topexpr env s.sloc e + | Sseq(s1, s2) -> + {sdesc = Sseq(add_stmt env s1, add_stmt env s2); sloc = s.sloc } + | Sif(e, s1, s2) -> + {sdesc = Sif(add_expr env e, add_stmt env s1, add_stmt env s2); + sloc = s.sloc} + | Swhile(e, s1) -> + {sdesc = Swhile(add_expr env e, add_stmt env s1); + sloc = s.sloc} + | Sdowhile(s1, e) -> + {sdesc = Sdowhile(add_stmt env s1, add_expr env e); + sloc = s.sloc} + | Sfor(s1, e, s2, s3) -> + {sdesc = Sfor(add_stmt env s1, add_expr env e, add_stmt env s2, + add_stmt env s3); + sloc = s.sloc} + | Sbreak -> s + | Scontinue -> s + | Sswitch(e, s1) -> + {sdesc = Sswitch(add_expr env e, add_stmt env s1); sloc = s.sloc} + | Slabeled(lbl, s) -> + {sdesc = Slabeled(lbl, add_stmt env s); sloc = s.sloc} + | Sgoto lbl -> s + | Sreturn None -> s + | Sreturn (Some e) -> + {sdesc = Sreturn(Some(add_expr env e)); sloc = s.sloc} + | Sblock sl -> + {sdesc = Sblock(List.map (add_stmt env) 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.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 diff --git a/cparser/AddCasts.mli b/cparser/AddCasts.mli new file mode 100644 index 0000000..318ecc6 --- /dev/null +++ b/cparser/AddCasts.mli @@ -0,0 +1,16 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Bitfields.ml b/cparser/Bitfields.ml new file mode 100644 index 0000000..4f7bcf1 --- /dev/null +++ b/cparser/Bitfields.ml @@ -0,0 +1,323 @@ +(* *********************************************************************) +(* *) +(* 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 } + +(* Programs *) + +let program p = + Transform.program ~composite:transf_composite ~fundef:transf_fundef p diff --git a/cparser/Bitfields.mli b/cparser/Bitfields.mli new file mode 100644 index 0000000..45899a4 --- /dev/null +++ b/cparser/Bitfields.mli @@ -0,0 +1,16 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Builtins.ml b/cparser/Builtins.ml new file mode 100644 index 0000000..eb10314 --- /dev/null +++ b/cparser/Builtins.ml @@ -0,0 +1,250 @@ +(* *********************************************************************) +(* *) +(* 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 + +(* 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 gcc_builtin_types = [ + "__builtin_va_list", voidPtrType +] + +let gcc_builtin_values = [ + "__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) +] + +let (builtin_env, builtin_idents) = + let env = ref Env.empty + and ids = ref [] in + List.iter + (fun (s, ty) -> + let (id, env') = Env.enter_typedef !env s ty in + env := env'; + ids := id :: !ids) + gcc_builtin_types; + List.iter + (fun (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'; + ids := id :: !ids) + gcc_builtin_values; + (!env, List.rev !ids) diff --git a/cparser/Builtins.mli b/cparser/Builtins.mli new file mode 100644 index 0000000..853bae9 --- /dev/null +++ b/cparser/Builtins.mli @@ -0,0 +1,17 @@ +(* *********************************************************************) +(* *) +(* 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 builtin_env : Env.t +val builtin_idents: C.ident list diff --git a/cparser/C.mli b/cparser/C.mli new file mode 100644 index 0000000..6744b38 --- /dev/null +++ b/cparser/C.mli @@ -0,0 +1,231 @@ +(* *********************************************************************) +(* *) +(* 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_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 diff --git a/cparser/Cabs.ml b/cparser/Cabs.ml new file mode 100644 index 0000000..a2bb512 --- /dev/null +++ b/cparser/Cabs.ml @@ -0,0 +1,299 @@ +(* + * + * 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 + + diff --git a/cparser/Cabshelper.ml b/cparser/Cabshelper.ml new file mode 100644 index 0000000..2dc1a91 --- /dev/null +++ b/cparser/Cabshelper.ml @@ -0,0 +1,126 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Ceval.ml b/cparser/Ceval.ml new file mode 100644 index 0000000..0e22852 --- /dev/null +++ b/cparser/Ceval.ml @@ -0,0 +1,277 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Ceval.mli b/cparser/Ceval.mli new file mode 100644 index 0000000..c7f7aa8 --- /dev/null +++ b/cparser/Ceval.mli @@ -0,0 +1,17 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Cleanup.ml b/cparser/Cleanup.ml new file mode 100644 index 0000000..be28989 --- /dev/null +++ b/cparser/Cleanup.ml @@ -0,0 +1,196 @@ +(* *********************************************************************) +(* *) +(* 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' + + + diff --git a/cparser/Cleanup.mli b/cparser/Cleanup.mli new file mode 100644 index 0000000..818a51b --- /dev/null +++ b/cparser/Cleanup.mli @@ -0,0 +1,16 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml new file mode 100644 index 0000000..508832b --- /dev/null +++ b/cparser/Cprint.ml @@ -0,0 +1,490 @@ +(* *********************************************************************) +(* *) +(* 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>%a" 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 "@]@." diff --git a/cparser/Cprint.mli b/cparser/Cprint.mli new file mode 100644 index 0000000..ce5fb18 --- /dev/null +++ b/cparser/Cprint.mli @@ -0,0 +1,32 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml new file mode 100644 index 0000000..c0c26e5 --- /dev/null +++ b/cparser/Cutil.ml @@ -0,0 +1,700 @@ +(* *********************************************************************) +(* *) +(* 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 + if ci.ci_incomplete + then None + else alignof_struct_union + (Env.add_composite env name {ci with ci_incomplete = true}) + ci.ci_members + | TUnion(name, _) -> + let ci = Env.find_union env name in + if ci.ci_incomplete + then None + else alignof_struct_union + (Env.add_composite env name {ci with ci_incomplete = true}) + ci.ci_members + +(* We set ci_incomplete to true before recursing so that we stop and + return None on ill-formed structs such as struct a { struct a x; }. *) + +and 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 + if ci.ci_incomplete + then None + else sizeof_struct + (Env.add_composite env name {ci with ci_incomplete = true}) + ci.ci_members + | TUnion(name, _) -> + let ci = Env.find_union env name in + if ci.ci_incomplete + then None + else sizeof_union + (Env.add_composite env name {ci with ci_incomplete = true}) + ci.ci_members + +(* We set ci_incomplete to true before recursing so that we stop and + return None on ill-formed structs such as struct a { struct a x; }. *) + +(* For a union, the size is the max of the sizes of fields, + rounded up to the natural alignment. *) + +and 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 + +(* For a struct, we lay out fields consecutively, inserting padding + to preserve their natural alignment. *) + +and 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 + +(* 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 + + diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli new file mode 100644 index 0000000..de32a21 --- /dev/null +++ b/cparser/Cutil.mli @@ -0,0 +1,169 @@ +(* *********************************************************************) +(* *) +(* 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. *) + +(* 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) *) + diff --git a/cparser/Elab.ml b/cparser/Elab.ml new file mode 100644 index 0000000..1091551 --- /dev/null +++ b/cparser/Elab.ml @@ -0,0 +1,1759 @@ +(* *********************************************************************) +(* *) +(* 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) + + +(** * 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 + + +(** * 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 3-tuple: + (storage class, 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 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 -> () + | SpecType tys -> tyspecs := tys :: !tyspecs in + + List.iter do_specifier specifier; + + let simple ty = (!sto, 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, 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, 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, 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, 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, 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, add_attributes_type a ty, env'') + +(* Elaboration of a name group *) + +and elab_name_group env (spec, namelist) = + let (sto, 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, 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; + ({ ci_kind = kind; ci_incomplete = false; ci_members = 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_incomplete = true} 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_incomplete = false}), 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 = { ci_kind = kind; ci_incomplete = true; ci_members = [] } 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 = { ci_kind = kind; ci_incomplete = true; ci_members = [] } 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, bty, env') = elab_specifier loc env spec in + let (ty, env'') = elab_type_declarator loc env' bty decl in + if sto <> Storage_default then + error loc "'extern' or 'static' storage not supported in cast"; + ty + + +(* 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 } + + +(* 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) + + +(* 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, 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_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, ty, env') = elab_specifier ~only:true loc env spec in + if sto <> Storage_default then + error loc "Non-default storage 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) + + +(* 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 + + +(** * Entry point *) + +let elab_preprocessed_file name ic = + let lb = Lexer.init name ic in + reset(); + ignore (elab_definitions false Builtins.builtin_env + (Parser.file Lexer.initial lb)); + Lexer.finish(); + elaborated_program() diff --git a/cparser/Elab.mli b/cparser/Elab.mli new file mode 100644 index 0000000..007e3d4 --- /dev/null +++ b/cparser/Elab.mli @@ -0,0 +1,16 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Env.ml b/cparser/Env.ml new file mode 100644 index 0000000..43ba4c3 --- /dev/null +++ b/cparser/Env.ml @@ -0,0 +1,247 @@ +(* *********************************************************************) +(* *) +(* 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_incomplete: bool; (* incompletely defined? *) + ci_members: field list (* members, in order *) +} + +(* 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 diff --git a/cparser/Env.mli b/cparser/Env.mli new file mode 100644 index 0000000..be9d6e8 --- /dev/null +++ b/cparser/Env.mli @@ -0,0 +1,69 @@ +(* *********************************************************************) +(* *) +(* 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_incomplete : bool; + ci_members : C.field list; +} + +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 diff --git a/cparser/Errors.ml b/cparser/Errors.ml new file mode 100644 index 0000000..188531e --- /dev/null +++ b/cparser/Errors.ml @@ -0,0 +1,55 @@ +(* *********************************************************************) +(* *) +(* 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) + + diff --git a/cparser/Errors.mli b/cparser/Errors.mli new file mode 100644 index 0000000..557fb14 --- /dev/null +++ b/cparser/Errors.mli @@ -0,0 +1,22 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Lexer.mli b/cparser/Lexer.mli new file mode 100644 index 0000000..ab89682 --- /dev/null +++ b/cparser/Lexer.mli @@ -0,0 +1,56 @@ +(* + * + * 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 *) + diff --git a/cparser/Lexer.mll b/cparser/Lexer.mll new file mode 100644 index 0000000..d4947ad --- /dev/null +++ b/cparser/Lexer.mll @@ -0,0 +1,604 @@ +(* + * + * 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) } + +{ + +} diff --git a/cparser/Machine.ml b/cparser/Machine.ml new file mode 100644 index 0000000..21b3daa --- /dev/null +++ b/cparser/Machine.ml @@ -0,0 +1,136 @@ +(* *********************************************************************) +(* *) +(* 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) diff --git a/cparser/Machine.mli b/cparser/Machine.mli new file mode 100644 index 0000000..bd3f357 --- /dev/null +++ b/cparser/Machine.mli @@ -0,0 +1,51 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Main.ml b/cparser/Main.ml new file mode 100644 index 0000000..de286b0 --- /dev/null +++ b/cparser/Main.ml @@ -0,0 +1,82 @@ +(* *********************************************************************) +(* *) +(* 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 _ = + 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 diff --git a/cparser/Makefile b/cparser/Makefile new file mode 100644 index 0000000..0ecd8f7 --- /dev/null +++ b/cparser/Makefile @@ -0,0 +1,89 @@ +OCAMLC=ocamlc -g +OCAMLOPT=ocamlopt -g +OCAMLLEX=ocamllex +OCAMLYACC=ocamlyacc -v +OCAMLDEP=ocamldep +OCAMLMKLIB=ocamlmklib + +LIBDIR=`$(OCAMLC) -where`/cparser + +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 Cleanup.ml \ + Builtins.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) + +all: cparser.cma cparser.cmxa cparser cparser.byte + +install: + mkdir -p $(LIBDIR) + cp -p Cparser.cmi cparser.cma cparser.cmxa cparser.a libcparser.a dllcparser.so $(LIBDIR) + +cparser: $(COBJS) $(NOBJS) Main.cmx + $(OCAMLOPT) -o cparser $(COBJS) $(NOBJS) Main.cmx + +clean:: + rm -f cparser + +cparser.byte: $(COBJS) $(BOBJS) Main.cmo + $(OCAMLC) -custom -o cparser.byte $(COBJS) $(BOBJS) Main.cmo + +clean:: + rm -f cparser + +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 + +depend: beforedepend + $(OCAMLDEP) *.mli *.ml > .depend + +include .depend diff --git a/cparser/Parse.ml b/cparser/Parse.ml new file mode 100644 index 0000000..7dcc8d1 --- /dev/null +++ b/cparser/Parse.ml @@ -0,0 +1,59 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Parse.mli b/cparser/Parse.mli new file mode 100644 index 0000000..58c3cfb --- /dev/null +++ b/cparser/Parse.mli @@ -0,0 +1,22 @@ +(* *********************************************************************) +(* *) +(* 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 *) diff --git a/cparser/Parse_aux.ml b/cparser/Parse_aux.ml new file mode 100755 index 0000000..6592245 --- /dev/null +++ b/cparser/Parse_aux.ml @@ -0,0 +1,46 @@ +(* *********************************************************************) +(* *) +(* 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 "" + diff --git a/cparser/Parse_aux.mli b/cparser/Parse_aux.mli new file mode 100644 index 0000000..7366aed --- /dev/null +++ b/cparser/Parse_aux.mli @@ -0,0 +1,22 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Parser.mly b/cparser/Parser.mly new file mode 100644 index 0000000..0eebb84 --- /dev/null +++ b/cparser/Parser.mly @@ -0,0 +1,1490 @@ +/*(* + * + * 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 } +; + +%% + + + diff --git a/cparser/Rename.ml b/cparser/Rename.ml new file mode 100644 index 0000000..6b94631 --- /dev/null +++ b/cparser/Rename.ml @@ -0,0 +1,253 @@ +(* *********************************************************************) +(* *) +(* 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_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.builtin_idents + +(* 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 + diff --git a/cparser/Rename.mli b/cparser/Rename.mli new file mode 100644 index 0000000..818a51b --- /dev/null +++ b/cparser/Rename.mli @@ -0,0 +1,16 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/SimplExpr.ml b/cparser/SimplExpr.ml new file mode 100644 index 0000000..484e2d8 --- /dev/null +++ b/cparser/SimplExpr.ml @@ -0,0 +1,564 @@ +(* *********************************************************************) +(* *) +(* 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 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 (sif e2' + (sassign tmp (intconst 1L IInt)) + (sassign tmp (intconst 0L IInt)))) + (sassign tmp (intconst 0L IInt))), + tmp) + | Set lv -> + let (s2, _) = simpl e2 (Set lv) in + (sseq s1 (sif e1' s2 (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 (sif e2' + (sassign tmp (intconst 1L IInt)) + (sassign tmp (intconst 0L IInt))))), + tmp) + | Set lv -> + let (s2, _) = simpl e2 (Set lv) in + (sseq s1 (sif e1' (sassign lv (intconst 1L IInt)) s2), + 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 diff --git a/cparser/SimplExpr.mli b/cparser/SimplExpr.mli new file mode 100644 index 0000000..cdeb30c --- /dev/null +++ b/cparser/SimplExpr.mli @@ -0,0 +1,20 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/StructAssign.ml b/cparser/StructAssign.ml new file mode 100644 index 0000000..bdaa2f5 --- /dev/null +++ b/cparser/StructAssign.ml @@ -0,0 +1,157 @@ +(* *********************************************************************) +(* *) +(* 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_incomplete 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' +***) diff --git a/cparser/StructAssign.mli b/cparser/StructAssign.mli new file mode 100644 index 0000000..5549282 --- /dev/null +++ b/cparser/StructAssign.mli @@ -0,0 +1,18 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/StructByValue.ml b/cparser/StructByValue.ml new file mode 100644 index 0000000..de79737 --- /dev/null +++ b/cparser/StructByValue.ml @@ -0,0 +1,235 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/StructByValue.mli b/cparser/StructByValue.mli new file mode 100644 index 0000000..45899a4 --- /dev/null +++ b/cparser/StructByValue.mli @@ -0,0 +1,16 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Transform.ml b/cparser/Transform.ml new file mode 100644 index 0000000..780e38e --- /dev/null +++ b/cparser/Transform.ml @@ -0,0 +1,80 @@ +(* *********************************************************************) +(* *) +(* 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) -> + let ci = {ci_kind = su; ci_incomplete = true; ci_members = []} in + (Gcompositedecl(su, id), Env.add_composite env id ci) + | Gcompositedef(su, id, fl) -> + let ci = {ci_kind = su; ci_incomplete = false; ci_members = fl} in + (Gcompositedef(su, id, composite env su id fl), + Env.add_composite env id ci) + | 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.builtin_env [] p diff --git a/cparser/Transform.mli b/cparser/Transform.mli new file mode 100644 index 0000000..960d890 --- /dev/null +++ b/cparser/Transform.mli @@ -0,0 +1,30 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Unblock.ml b/cparser/Unblock.ml new file mode 100644 index 0000000..fa304b7 --- /dev/null +++ b/cparser/Unblock.ml @@ -0,0 +1,133 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/Unblock.mli b/cparser/Unblock.mli new file mode 100644 index 0000000..e6bea9e --- /dev/null +++ b/cparser/Unblock.mli @@ -0,0 +1,18 @@ +(* *********************************************************************) +(* *) +(* 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 diff --git a/cparser/uint64.c b/cparser/uint64.c new file mode 100644 index 0000000..5396617 --- /dev/null +++ b/cparser/uint64.c @@ -0,0 +1,42 @@ +/* *********************************************************************/ +/* */ +/* 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); +} + diff --git a/driver/Clflags.ml b/driver/Clflags.ml index ddcfaac..79b233a 100644 --- a/driver/Clflags.ml +++ b/driver/Clflags.ml @@ -16,8 +16,15 @@ let prepro_options = ref ([]: string list) let linker_options = ref ([]: string list) let exe_name = ref "a.out" let option_flonglong = ref false +let option_fstruct_passing = ref false +let option_fstruct_assign = ref false +let option_fbitfields = ref false +let option_fvararg_calls = ref true +let all_extensions = + [option_fstruct_passing; option_fstruct_assign; option_fbitfields; + option_fvararg_calls; option_flonglong] let option_fmadd = ref false -let option_dcil = ref false +let option_dparse = ref false let option_dclight = ref false let option_dasm = ref false let option_E = ref false diff --git a/driver/Driver.ml b/driver/Driver.ml index aed0221..a6b865c 100644 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -43,47 +43,6 @@ let print_error oc msg = List.iter print_one_error msg; output_char oc '\n' -(* For the CIL -> Csyntax translator: - - * The meaning of some type specifiers may depend on compiler options: - the size of an int or the default signedness of char, for instance. - - * Those type conversions may be parameterized thanks to a functor. - - * Remark: [None] means that the type specifier is not supported - (that is, an Unsupported exception will be raised if that type - specifier is encountered in the program). -*) - -module TypeSpecifierTranslator = struct - - open Cil - open Csyntax - - (** Convert a Cil.ikind into an (intsize * signedness) option *) - let convertIkind = function - | IChar -> Some (I8, Unsigned) - | ISChar -> Some (I8, Signed) - | IUChar -> Some (I8, Unsigned) - | IInt -> Some (I32, Signed) - | IUInt -> Some (I32, Unsigned) - | IShort -> Some (I16, Signed) - | IUShort -> Some (I16, Unsigned) - | ILong -> Some (I32, Signed) - | IULong -> Some (I32, Unsigned) - | ILongLong -> if !option_flonglong then Some (I32, Signed) else None - | IULongLong -> if !option_flonglong then Some (I32, Unsigned) else None - - (** Convert a Cil.fkind into an floatsize option *) - let convertFkind = function - | FFloat -> Some F32 - | FDouble -> Some F64 - | FLongDouble -> if !option_flonglong then Some F64 else None - -end - -module Cil2CsyntaxTranslator = Cil2Csyntax.Make(TypeSpecifierTranslator) - (* From C to preprocessed C *) let preprocess ifile ofile = @@ -102,38 +61,31 @@ let preprocess ifile ofile = (* From preprocessed C to asm *) let compile_c_file sourcename ifile ofile = - (* Parsing and production of a CIL.file *) - let cil = - try - Frontc.parse ifile () - with - | Frontc.ParseError msg -> - eprintf "Error during parsing: %s\n" msg; - exit 2 - | Errormsg.Error -> - exit 2 in + (* Simplification options *) + let simplifs = + "bec" (* blocks, impure exprs, implicit casts: mandatory *) + ^ (if !option_fstruct_passing then "s" else "") + ^ (if !option_fstruct_assign then "S" else "") + ^ (if !option_fbitfields then "f" else "") in + (* Parsing and production of a simplified C AST *) + let ast = + match Cparser.Parse.preprocessed_file simplifs sourcename ifile with + | None -> exit 2 + | Some p -> p in (* Remove preprocessed file (always a temp file) *) safe_remove ifile; - (* Restore original source file name *) - cil.Cil.fileName <- sourcename; - (* Cleanup in the CIL.file *) - Rmtmps.removeUnusedTemps ~isRoot:Rmtmps.isExportedRoot cil; - (* Save CIL output if requested *) - if !option_dcil then begin - let ofile = Filename.chop_suffix sourcename ".c" ^ ".cil.c" in + (* Save C AST if requested *) + if !option_dparse then begin + let ofile = Filename.chop_suffix sourcename ".c" ^ ".parsed.c" in let oc = open_out ofile in - Cil.dumpFile Cil.defaultCilPrinter oc ofile cil; + Cparser.Cprint.program (Format.formatter_of_out_channel oc) ast; close_out oc end; (* Conversion to Csyntax *) let csyntax = - try - Cil2CsyntaxTranslator.convertFile cil - with - | Cil2Csyntax.Error msg -> - eprintf "%s\n" msg; - exit 2 - in + match C2Clight.convertProgram ast with + | None -> exit 2 + | Some p -> p in (* Save Csyntax if requested *) if !option_dclight then begin let ofile = Filename.chop_suffix sourcename ".c" ^ ".light.c" in @@ -262,12 +214,20 @@ Preprocessing options: -I<dir> Add <dir> to search path for #include files -D<symb>=<val> Define preprocessor symbol -U<symb> Undefine preprocessor symbol -Compilation options: - -flonglong Treat 'long long' as 'long' and 'long double' as 'double' +Language support options (use -fno-<opt> to turn off -f<opt>) : + -fbitfields Emulate bit fields in structs [off] + -flonglong Treat 'long long' as 'long' and 'long double' as 'double' [off] + -fstruct-passing Emulate passing structs and unions by value [off] + -fstruct-assign Emulate assignment between structs or unions [off] + -fvararg-calls Emulate calls to variable-argument functions [on] + -fall-extensions Activate all of the above + -fno-extensions Deactivate all of the above +Code generation options: -fmadd Use fused multiply-add and multiply-sub instructions -fsmall-data <n> Set maximal size <n> for allocation in small data area -fsmall-const <n> Set maximal size <n> for allocation in small constant area - -dcil Save CIL-processed source in <file>.cil.c +Tracing options: + -dparse Save C file after parsing and elaboration in <file>.parse.c -dclight Save generated Clight in <file>.light.c -dasm Save generated assembly in <file>.s Linking options: @@ -281,6 +241,7 @@ General options: type action = | Set of bool ref + | Unset of bool ref | Self of (string -> unit) | String of (string -> unit) | Integer of (int -> unit) @@ -305,6 +266,8 @@ let parse_cmdline spec usage = error () | Some(Set r) -> r := true; parse (i+1) + | Some(Unset r) -> + r := false; parse (i+1) | Some(Self fn) -> fn s; parse (i+1) | Some(String fn) -> @@ -329,16 +292,15 @@ let parse_cmdline spec usage = end in parse 1 -let cmdline_actions = [ +let cmdline_actions = + let f_opt name ref = + ["-f" ^ name ^ "$", Set ref; "-fno-" ^ name ^ "$", Unset ref] in + [ "-[IDU].", Self(fun s -> prepro_options := s :: !prepro_options); "-[lL].", Self(fun s -> linker_options := s :: !linker_options); "-o$", String(fun s -> exe_name := s); "-stdlib$", String(fun s -> stdlib_path := s); - "-flonglong$", Set option_flonglong; - "-fmadd$", Set option_fmadd; - "-fsmall-data$", Integer(fun n -> option_small_data := n); - "-fsmall-const$", Integer(fun n -> option_small_const := n); - "-dcil$", Set option_dcil; + "-dparse$", Set option_dparse; "-dclight$", Set option_dclight; "-dasm$", Set option_dasm; "-E$", Set option_E; @@ -352,11 +314,23 @@ let cmdline_actions = [ let objfile = process_cminor_file s in linker_options := objfile :: !linker_options); ".*\\.[oa]$", Self (fun s -> - linker_options := s :: !linker_options) -] + linker_options := s :: !linker_options); + "-fsmall-data$", Integer(fun n -> option_small_data := n); + "-fsmall-const$", Integer(fun n -> option_small_const := n); + "-fno-extensions", Self (fun s -> + List.iter (fun r -> r := false) Clflags.all_extensions); + "-fall-extensions", Self (fun s -> + List.iter (fun r -> r := true) Clflags.all_extensions) + ] + @ f_opt "longlong" option_flonglong + @ f_opt "struct-passing" option_fstruct_passing + @ f_opt "struct-assign" option_fstruct_assign + @ f_opt "bitfields" option_fbitfields + @ f_opt "vararg-calls" option_fvararg_calls + @ f_opt "madd" option_fmadd let _ = - Cil.initCIL(); + Cparser.Machine.config := Cparser.Machine.ilp32ll64; CPragmas.initialize(); parse_cmdline cmdline_actions usage_string; if !linker_options <> [] diff --git a/lib/Camlcoq.ml b/lib/Camlcoq.ml index 2cb1093..51915fd 100644 --- a/lib/Camlcoq.ml +++ b/lib/Camlcoq.ml @@ -6,6 +6,9 @@ (* *) (* 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. *) (* *) (* *********************************************************************) diff --git a/myocamlbuild.ml b/myocamlbuild.ml new file mode 100644 index 0000000..41b4cfc --- /dev/null +++ b/myocamlbuild.ml @@ -0,0 +1,17 @@ +open Ocamlbuild_plugin;; +dispatch begin function +| After_rules -> + (* declare the tags "use_Cparser" and "include_Cparser" *) + ocaml_lib "cfrontend/Cparser"; + + (* force linking of libCparser.a when use_Cparser is set *) + flag ["link"; "ocaml"; "native"; "use_Cparser"] + (S[A"cfrontend/libCparser.a"]); + flag ["link"; "ocaml"; "byte"; "use_Cparser"] + (S[A"-custom"; A"cfrontend/libCparser.a"]); + + (* make sure libCparser.a is up to date *) + dep ["link"; "ocaml"; "use_Cparser"] ["cfrontend/libCparser.a"]; + +| _ -> () +end diff --git a/powerpc/PrintAsm.ml b/powerpc/PrintAsm.ml index 50a8474..8bf40a9 100644 --- a/powerpc/PrintAsm.ml +++ b/powerpc/PrintAsm.ml @@ -496,7 +496,7 @@ let print_function oc name code = | Some s -> s | None -> text); fprintf oc " .align 2\n"; - if not (Cil2Csyntax.atom_is_static name) then + if not (C2Clight.atom_is_static name) then fprintf oc " .globl %a\n" symbol name; fprintf oc "%a:\n" symbol name; List.iter (print_instruction oc (labels_of_code Labelset.empty code)) code @@ -712,13 +712,13 @@ let print_var oc (Coq_pair(Coq_pair(name, init_data), _)) = match CPragmas.section_for_atom name init with | Some s -> s | None -> - if Cil2Csyntax.atom_is_readonly name + if C2Clight.atom_is_readonly name then const_data else data in section oc sec; fprintf oc " .align 3\n"; - if not (Cil2Csyntax.atom_is_static name) then + if not (C2Clight.atom_is_static name) then fprintf oc " .globl %a\n" symbol name; fprintf oc "%a:\n" symbol name; print_init_data oc init_data diff --git a/test/regression/Makefile b/test/regression/Makefile new file mode 100644 index 0000000..2af20e6 --- /dev/null +++ b/test/regression/Makefile @@ -0,0 +1,40 @@ +include ../../Makefile.config + +CCOMP=../../ccomp +CCOMPFLAGS=-stdlib ../../runtime -dparse -dclight -dasm -fall-extensions + +LIBS=$(LIBMATH) + +# Can run and have reference output in Results +TESTS=bitfields1 expr1 initializers + +# Other tests: should compile to .s without errors (but expect warnings) +EXTRAS=commaprec expr2 expr3 expr4 extern1 funct2 funptr1 init1 \ + init2 init3 init4 pragmas ptrs1 ptrs2 sizeof1 struct1 struct2 struct3 \ + struct4 struct5 struct6 types1 volatile1 + +# Test known to fail +FAILURES=funct1 varargs1 + +all_s: $(TESTS:%=%.s) $(EXTRAS:%=%.s) + +all: $(TESTS:%=%.compcert) $(EXTRAS:%=%.s) + +%.compcert: %.c $(CCOMP) + $(CCOMP) $(CCOMPFLAGS) -o $*.compcert $*.c $(LIBS) + +%.s: %.c $(CCOMP) + $(CCOMP) $(CCOMPFLAGS) -S $*.c + +clean: + rm -f *.compcert + rm -f *.parsed.c *.light.c *.s *.o *~ + +test_compcert: + @for i in $(TESTS); do \ + if ./$$i.compcert | cmp -s - Results/$$i; \ + then echo "$$i: passed"; \ + else echo "$$i: FAILED"; \ + fi; \ + done + diff --git a/test/regression/Results/bitfields1 b/test/regression/Results/bitfields1 new file mode 100644 index 0000000..3b2bb6a --- /dev/null +++ b/test/regression/Results/bitfields1 @@ -0,0 +1,3 @@ +x = {a = -6, b = 2 } +y = {c = 12345, d = 1, e = 89 } +f returns 12434 diff --git a/test/regression/Results/expr1 b/test/regression/Results/expr1 new file mode 100644 index 0000000..dc49203 --- /dev/null +++ b/test/regression/Results/expr1 @@ -0,0 +1 @@ +Result: 0x0 diff --git a/test/regression/bitfields1.c b/test/regression/bitfields1.c new file mode 100644 index 0000000..c6022dd --- /dev/null +++ b/test/regression/bitfields1.c @@ -0,0 +1,39 @@ +#include <stdio.h> + +struct s { + signed char a: 6; + unsigned int b: 2; +}; + +struct t { + unsigned int c: 16; + unsigned int d: 1; + short e: 8; +}; + +int f(struct s * x, struct t * y, int z) +{ + x->a += x->b; + y->d = z; + return y->c + y->e; +} + +int main() +{ + struct s x; + struct t y; + int res; + + x.a = 56; + x.b = 2; + y.c = 12345; + y.d = 0; + y.e = 89; + res = f(&x, &y, 1); + + printf("x = {a = %d, b = %d }\n", x.a, x.b); + printf("y = {c = %d, d = %d, e = %d }\n", y.c, y.d, y.e); + printf("f returns %d\n", res); + + return 0; +} diff --git a/test/regression/commaprec.c b/test/regression/commaprec.c new file mode 100644 index 0000000..aa18eda --- /dev/null +++ b/test/regression/commaprec.c @@ -0,0 +1,6 @@ +extern int f(int, int); + +int g(int y) { + int z = (y++, 0); + return f((z = 1, z), y+2); +} diff --git a/test/regression/expr1.c b/test/regression/expr1.c new file mode 100644 index 0000000..0cc7b54 --- /dev/null +++ b/test/regression/expr1.c @@ -0,0 +1,17 @@ +#include <stdio.h> + +struct list { int hd; struct list * tl; }; + +struct list * f(struct list ** p) +{ + return ((*p)->tl = 0); +} + +int main(int argc, char ** argv) +{ + struct list l; + l.tl = &l; + f(&(l.tl)); + printf("Result: %p\n", l.tl); + return 0; +} diff --git a/test/regression/expr2.c b/test/regression/expr2.c new file mode 100644 index 0000000..66c563f --- /dev/null +++ b/test/regression/expr2.c @@ -0,0 +1,8 @@ +extern int f(int); + +void g(int x) +{ + if (x > 0) { + (void) f(x - 1); + } +} diff --git a/test/regression/expr3.c b/test/regression/expr3.c new file mode 100644 index 0000000..9b696e5 --- /dev/null +++ b/test/regression/expr3.c @@ -0,0 +1,7 @@ +/* Array decay in && */ + +struct s { + int a[1]; +}; + +int f(struct s * x) { return x && x->a; } diff --git a/test/regression/expr4.c b/test/regression/expr4.c new file mode 100644 index 0000000..ad86eae --- /dev/null +++ b/test/regression/expr4.c @@ -0,0 +1,5 @@ +/* Warning, not error */ + +#define NULL ((void *) 0) + +int f(int x) { return x == NULL; } diff --git a/test/regression/extern1.c b/test/regression/extern1.c new file mode 100644 index 0000000..86def95 --- /dev/null +++ b/test/regression/extern1.c @@ -0,0 +1,8 @@ +int x = 5; +int f() { + int x = 3; + { + extern int x; + return x; + } +} diff --git a/test/regression/funct1.c b/test/regression/funct1.c new file mode 100644 index 0000000..1e26803 --- /dev/null +++ b/test/regression/funct1.c @@ -0,0 +1,8 @@ +int f() { return 0; } + +int g(void) { return f(1); } + +int h(x, y) int x, y; { return x + y; } + +int k(void) { return h(1); } + diff --git a/test/regression/funct2.c b/test/regression/funct2.c new file mode 100644 index 0000000..6b648c7 --- /dev/null +++ b/test/regression/funct2.c @@ -0,0 +1,4 @@ +extern int f(int x); + +double g(int x) { return 3.14 * f(x); } + diff --git a/test/regression/funptr1.c b/test/regression/funptr1.c new file mode 100644 index 0000000..9bb7046 --- /dev/null +++ b/test/regression/funptr1.c @@ -0,0 +1,10 @@ +int (*pf)(void); +int f(void) { + + pf = &f; // This looks ok + pf = ***f; // Dereference a function? + pf(); // Invoke a function pointer? + (****pf)(); // Looks strange but Ok + (***************f)(); // Also Ok + return 0; +} diff --git a/test/regression/init1.c b/test/regression/init1.c new file mode 100644 index 0000000..ea9db0f --- /dev/null +++ b/test/regression/init1.c @@ -0,0 +1,3 @@ +/* Initializer can refer to ident just declared */ + +struct list { int hd; struct list * tl; } circular = { sizeof(circular), &circular }; diff --git a/test/regression/init2.c b/test/regression/init2.c new file mode 100644 index 0000000..400bd94 --- /dev/null +++ b/test/regression/init2.c @@ -0,0 +1,8 @@ +/* Initialization of local const array */ + +int f(int x) +{ + const int dfl = 2; + const int tbl[3] = { 12, 34, 56 }; + return tbl[x >= 0 && x < 3 ? x : dfl]; +} diff --git a/test/regression/init3.c b/test/regression/init3.c new file mode 100644 index 0000000..00a36e2 --- /dev/null +++ b/test/regression/init3.c @@ -0,0 +1,6 @@ +/* Warning, not error */ + +#define NULL ((void *) 0) + +char x = NULL; +int t[2] = { NULL, NULL }; diff --git a/test/regression/init4.c b/test/regression/init4.c new file mode 100644 index 0000000..02b0bd5 --- /dev/null +++ b/test/regression/init4.c @@ -0,0 +1,13 @@ +/* C99-style initializers in the middle of a block */ + +int g(int x) { return x << 2; } + +int f(int x, int y) +{ + int a = x + y; + { + y++; + int b = y - g(x); + return b * a; + } +} diff --git a/test/regression/ptrs1.c b/test/regression/ptrs1.c new file mode 100644 index 0000000..3585a8f --- /dev/null +++ b/test/regression/ptrs1.c @@ -0,0 +1 @@ +const char * f(char * p, const char * q) { return p == q ? p : q; } diff --git a/test/regression/ptrs2.c b/test/regression/ptrs2.c new file mode 100644 index 0000000..0b66ed2 --- /dev/null +++ b/test/regression/ptrs2.c @@ -0,0 +1,26 @@ +#include <stdlib.h> + +typedef double Matrix[4][4]; + +Matrix * CopyMatrix(Matrix * Mat) { + int i,j; + Matrix * Res = NULL; + if (Mat == 0) return Mat; + Res = malloc(sizeof(Matrix)); + for(i=0;i<4;i++){ + for(j=0;j<4;j++){ + (*Res)[i][j] = (*Mat)[i][j]; + } + } + return Res; +} + +Matrix * IdentMatrix(void) +{ + Matrix SI = { { 1.00, 0.00, 0.00, 0.00 }, + { 0.00, 1.00, 0.00, 0.00 }, + { 0.00, 0.00, 1.00, 0.00 }, + { 0.00, 0.00, 0.00, 1.00 }}; + return CopyMatrix(&SI); +} + diff --git a/test/regression/sizeof1.c b/test/regression/sizeof1.c new file mode 100644 index 0000000..e8441a2 --- /dev/null +++ b/test/regression/sizeof1.c @@ -0,0 +1,31 @@ +struct s { + char c; + union { int i[3]; double d; } n; + struct { struct s * hd; struct s * tl; } l; +}; + +char tbl[sizeof(struct s)]; +/* Should be 32: + char c at 0 + union n at 8 because alignment = 8; sizeof = 12 + struct l at 8+12=20 with alignment = 4; sizeof = 8 + end of struct at 20+8=28 + alignment of whole struct is 8 because of d + 28 aligned to 8 -> 32 +*/ + +struct bits1 { + unsigned a: 1; + unsigned b: 6; +}; + +char b1[sizeof(struct bits1)]; /* should be 1 */ + +struct bits2 { + unsigned a: 1; + unsigned b: 6; + unsigned c: 28; +}; + +char b2[sizeof(struct bits2)]; /* should be 8 */ + diff --git a/test/regression/struct1.c b/test/regression/struct1.c new file mode 100644 index 0000000..2203fe7 --- /dev/null +++ b/test/regression/struct1.c @@ -0,0 +1,8 @@ +struct s; + +struct s { int x; double y; }; + +struct s my_s; + +double f(struct s * a) { return a->y; } + diff --git a/test/regression/struct2.c b/test/regression/struct2.c new file mode 100644 index 0000000..10437e2 --- /dev/null +++ b/test/regression/struct2.c @@ -0,0 +1,4 @@ +struct B; +int f(struct B); +struct B { double d; }; +int g() { struct B b; return f(b); } diff --git a/test/regression/struct3.c b/test/regression/struct3.c new file mode 100644 index 0000000..e98bf12 --- /dev/null +++ b/test/regression/struct3.c @@ -0,0 +1,17 @@ +int f() { + { + struct B; + struct B { double d; }; + { + struct B; + extern void bar(struct B d); + struct B { + int k; + short h; + }; + struct B p = { 1, 2}; + bar(p); + } + } + return 0; +} diff --git a/test/regression/struct4.c b/test/regression/struct4.c new file mode 100644 index 0000000..8cb3c19 --- /dev/null +++ b/test/regression/struct4.c @@ -0,0 +1,9 @@ +struct obj { + int tag; + union { + struct { struct obj * car, * cdr; } cons; + struct { char * name; struct obj * plist; } atom; + } u; +}; + +struct obj some_obj; diff --git a/test/regression/struct5.c b/test/regression/struct5.c new file mode 100644 index 0000000..13a1aa5 --- /dev/null +++ b/test/regression/struct5.c @@ -0,0 +1,43 @@ +typedef struct HPointStruct +{ + double x; + double y; + double z; + double w; +}HPoint; + +typedef struct ObjPointStruct +{ + double x; + double y; + double z; + double tx; + double ty; + double tz; +}ObjPoint; + +HPoint PointToHPoint(ObjPoint P); + +HPoint PointToHPoint(ObjPoint P) +{ + HPoint res; + res.x = P.x; + res.y = P.y; + res.z = P.z; + res.w = 1; + return res; +} + +double test1(HPoint (*f)(ObjPoint), double x) +{ + ObjPoint P; + HPoint HP; + P.x = x; + HP = f(P); + return HP.x; +} + +double test2(double x) +{ + return test1(PointToHPoint, x); +} diff --git a/test/regression/struct6.c b/test/regression/struct6.c new file mode 100644 index 0000000..d8d9cc9 --- /dev/null +++ b/test/regression/struct6.c @@ -0,0 +1,17 @@ +#include <stdio.h> + +struct value { + int tag; + union { + int i; + double r; + char * sl; + } u; +}; + +void print_value(struct value * s) +{ + printf ("%d\n", s->u.i); +} + + diff --git a/test/regression/types1.c b/test/regression/types1.c new file mode 100644 index 0000000..c05e30d --- /dev/null +++ b/test/regression/types1.c @@ -0,0 +1,15 @@ +/* Printing of modifiers */ + +typedef struct vba_version_tag { + unsigned char signature[4]; + const char *name; + int is_mac; +} vba_version_t; + +static const vba_version_t vba_version[10]; + +int f(int x) +{ + return sizeof(vba_version[0].signature); +} + diff --git a/test/regression/varargs1.c b/test/regression/varargs1.c new file mode 100644 index 0000000..99dba39 --- /dev/null +++ b/test/regression/varargs1.c @@ -0,0 +1,18 @@ +#include <stdarg.h> + +int sum_v(int n, va_list ap) +{ + int i, s; + for (i = 0, s = 0; i < n; i++) s += va_arg(ap, int); + return s; +} + +int sum_l(int n, ...) +{ + va_list ap; + int s; + va_start(ap, n); + s = sum_v(n, ap); + va_end(ap); + return s; +} diff --git a/test/regression/volatile1.c b/test/regression/volatile1.c new file mode 100644 index 0000000..3818c23 --- /dev/null +++ b/test/regression/volatile1.c @@ -0,0 +1,9 @@ +volatile int v; + +int f1(void) { return v; } + +int f2(void) { return v++; } + +int f3(void) {return v / v + 1 + v; } + +void f4(void) { v; } |