From 712f3cbae6bfd3c6f6cc40d44f438aa0affcd371 Mon Sep 17 00:00:00 2001 From: xleroy Date: Tue, 18 Dec 2012 07:54:35 +0000 Subject: Support for inline assembly (asm statements). cparser: add primitive support for enum types. bitfield emulation: for bitfields with enum type, choose signed/unsigned as appropriate git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@2074 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- cparser/Elab.ml | 76 +++++++++++++++++++++++++++++++++------------------------ 1 file changed, 44 insertions(+), 32 deletions(-) (limited to 'cparser/Elab.ml') diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 0e7b549..6807d0c 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -425,10 +425,9 @@ let rec elab_specifier ?(only = false) loc env specifier = (!sto, !inline, TUnion(id', !attr), env') | [Cabs.Tenum(id, optmembers, a)] -> - let env' = - elab_enum loc id optmembers env in - let attr' = add_attributes !attr (elab_attributes loc env a) in - (!sto, !inline, TInt(enum_ikind, attr'), env') + let (id', env') = + elab_enum loc id optmembers a env in + (!sto, !inline, TEnum(id', !attr), env') | [Cabs.TtypeofE _] -> fatal_error loc "GCC __typeof__ not supported" @@ -549,28 +548,29 @@ and elab_field_group env (spec, fieldlist) = let ik = match unroll env' ty with | TInt(ik, _) -> ik + | TEnum(_, _) -> enum_ikind | _ -> 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'"; + "the type of '%s' must be an integer type \ + no bigger than 'int'" id; 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 %s (%Ld) is negative" id n; + error loc "bit size of '%s' (%Ld) is negative" id n; None end else if n > Int64.of_int(sizeof_ikind ik * 8) then begin - error loc "bit size of member %s (%Ld) is too large" id n; + error loc "bit size of '%s' (%Ld) exceeds its type" id n; None end else if n = 0L && id <> "" then begin - error loc "member %s has zero size" id; + error loc "member '%s' has zero size" id; None end else Some(Int64.to_int n) | None -> - error loc "bit size of member %s is not a compile-time constant" id; + error loc "bit size of '%s' is not a compile-time constant" id; None in { fld_name = id; fld_typ = ty; fld_bitfield = optbitsize' } in @@ -673,14 +673,21 @@ and elab_enum_item env (s, exp, loc) nextval = (nextval, Some exp') in if redef Env.lookup_ident env s <> None then error loc "redefinition of enumerator '%s'" s; + if not (int_representable v (8 * sizeof_ikind enum_ikind) (is_signed_ikind enum_ikind)) then + warning loc "the value of '%s' is not representable with type %a" + s Cprint.typ (TInt(enum_ikind, [])); let (id, env') = Env.enter_enum_item env s v in - ((id, exp'), Int64.succ v, env') + ((id, v, exp'), Int64.succ v, env') (* Elaboration of an enumeration declaration *) -and elab_enum loc tag optmembers env = +and elab_enum loc tag optmembers attrs env = + let attrs' = + elab_attributes loc env attrs in match optmembers with - | None -> env + | None -> + let (tag', info) = wrap Env.lookup_enum loc env tag in (tag', env) + (* XXX this will cause an error for incomplete enum definitions. *) | Some members -> let rec elab_members env nextval = function | [] -> ([], env) @@ -689,9 +696,10 @@ and elab_enum loc tag optmembers env = 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' + let info = { ei_members = dcls; ei_attr = attrs' } in + let (tag', env'') = Env.enter_enum env' tag info in + emit_elab (elab_loc loc) (Genumdef(tag', attrs', dcls)); + (tag', env'') (* Elaboration of a naked type, e.g. in a cast *) @@ -739,8 +747,8 @@ let elab_expr loc env a = 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 + | (TPtr(t, _) | TArray(t, _, _)), (TInt _ | TEnum _) -> t + | (TInt _ | TEnum _), (TPtr(t, _) | TArray(t, _, _)) -> t | t1, t2 -> error "incorrect types for array subscripting" in { edesc = EBinop(Oindex, b1, b2, TPtr(tres, [])); etyp = tres } @@ -801,6 +809,7 @@ let elab_expr loc env a = having declared it *) match a1 with | VARIABLE n when not (Env.ident_is_bound env n) -> + warning "implicit declaration of function '%s'" n; let ty = TFun(TInt(IInt, []), None, false, []) in (* Emit an extern declaration for it *) let id = Env.fresh_ident n in @@ -944,8 +953,8 @@ let elab_expr loc env a = 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) + | (TPtr(ty, a) | TArray(ty, _, a)), (TInt _ | TEnum _) -> (ty, a) + | (TInt _ | TEnum _), (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 '+'"; @@ -962,11 +971,11 @@ let elab_expr loc env a = (tyres, tyres) end else begin match unroll env b1.etyp, unroll env b2.etyp with - | (TPtr(ty, a) | TArray(ty, _, a)), TInt _ -> + | (TPtr(ty, a) | TArray(ty, _, a)), (TInt _ | TEnum _) -> 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)) -> + | (TInt _ | TEnum _), (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)) @@ -1022,7 +1031,7 @@ let elab_expr loc env a = 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 _) -> + | (TInt _ | TFloat _ | TEnum _), (TInt _ | TFloat _ | TEnum _) -> { edesc = EConditional(b1, b2, b3); etyp = binary_conversion env b2.etyp b3.etyp } | TPtr(ty1, a1), TPtr(ty2, a2) -> @@ -1170,7 +1179,7 @@ let elab_expr loc env a = let b2 = elab a2 in let resdesc = match pointer_decay env b1.etyp, pointer_decay env b2.etyp with - | (TInt _ | TFloat _), (TInt _ | TFloat _) -> + | (TInt _ | TFloat _ | TEnum _), (TInt _ | TFloat _ | TEnum _) -> 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, [])) @@ -1186,8 +1195,8 @@ let elab_expr loc env a = 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 _ -> + | TPtr _, (TInt _ | TEnum _) + | (TInt _ | TEnum _), TPtr _ -> warning "comparison between integer and pointer"; EBinop(op, b1, b2, TPtr(TVoid [], [])) | ty1, ty2 -> @@ -1374,7 +1383,7 @@ let rec elab_init loc env ty ile = let (i, rem) = elab_init loc env fld1.fld_typ ile in (Init_union(id, fld1, i), rem) end - | TInt _ | TFloat _ | TPtr _ -> + | TInt _ | TFloat _ | TPtr _ | TEnum _ -> begin match ile with (* scalar = elt *) | SINGLE_INIT a :: ile1 -> @@ -1384,7 +1393,7 @@ let rec elab_init loc env ty ile = (* 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) + | TInt _ | TEnum _ -> (Init_single (intconst 0L IInt), ile1) | TFloat _ -> (Init_single floatconst0, ile1) | TPtr _ -> (Init_single nullconst, ile1) | _ -> assert false @@ -1399,7 +1408,7 @@ 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 -> + | (TInt _ | TFloat _ | TPtr _ | TStruct _ | TUnion _ | TEnum _), SINGLE_INIT a -> let a' = elab_expr loc env a in check_init_type loc env a' ty; Some (Init_single a') @@ -1777,6 +1786,12 @@ let rec elab_stmt env ctx s = | NOP loc -> { sdesc = Sskip; sloc = elab_loc loc } +(* Traditional extensions *) + | ASM(attr, txt, details, loc) -> + if details <> None then + error loc "GCC's extended 'asm' statements are not supported"; + { sdesc = Sasm(String.concat "" txt); sloc = elab_loc loc } + (* Unsupported *) | DEFINITION def -> error (get_definitionloc def) "ill-placed definition"; @@ -1784,9 +1799,6 @@ let rec elab_stmt env ctx s = | 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 -- cgit v1.2.3