diff options
-rw-r--r-- | cfrontend/C2C.ml | 16 | ||||
-rw-r--r-- | common/Sections.ml | 3 | ||||
-rw-r--r-- | common/Sections.mli | 2 | ||||
-rw-r--r-- | cparser/Cprint.ml | 15 | ||||
-rw-r--r-- | cparser/Cutil.ml | 38 | ||||
-rw-r--r-- | cparser/Cutil.mli | 21 | ||||
-rw-r--r-- | cparser/Elab.ml | 70 | ||||
-rw-r--r-- | cparser/GCC.ml | 24 | ||||
-rw-r--r-- | cparser/GCC.mli | 3 | ||||
-rwxr-xr-x | driver/Driver.ml | 1 | ||||
-rw-r--r-- | test/regression/attribs1.c | 2 |
11 files changed, 148 insertions, 47 deletions
diff --git a/cfrontend/C2C.ml b/cfrontend/C2C.ml index 91941d74..f2fbf255 100644 --- a/cfrontend/C2C.ml +++ b/cfrontend/C2C.ml @@ -260,6 +260,20 @@ let builtins = Builtins.({ typedefs = builtins_generic.typedefs @ CBuiltins.builtins.typedefs; functions = builtins_generic.Builtins.functions @ CBuiltins.builtins.functions }) +(** ** The known attributes *) + +let attributes = [ + (* type-related *) + ("aligned", Cutil.Attr_type); + (* struct-related *) + ("packed", Cutil.Attr_struct); + (* function-related *) + ("noreturn", Cutil.Attr_function); + (* name-related *) + ("section", Cutil.Attr_name) +] + + (** ** Functions used to handle string literals *) let stringNum = ref 0 (* number of next global for string literals *) @@ -1091,7 +1105,7 @@ let convertFundef loc env fd = Hashtbl.add decl_atom id' { a_storage = fd.fd_storage; a_alignment = None; - a_sections = Sections.for_function env id' fd.fd_ret; + a_sections = Sections.for_function env id' fd.fd_attrib; a_access = Sections.Access_default; a_inline = fd.fd_inline && not fd.fd_vararg; (* PR#15 *) a_loc = loc }; diff --git a/common/Sections.ml b/common/Sections.ml index b792581f..1c2e8291 100644 --- a/common/Sections.ml +++ b/common/Sections.ml @@ -189,8 +189,7 @@ let for_variable env id ty init = (* Determine sections for a function definition *) -let for_function env id ty_res = - let attr = Cutil.attributes_of_type env ty_res in +let for_function env id attr = let si_code = try (* 1- Section explicitly associated with #use_section *) diff --git a/common/Sections.mli b/common/Sections.mli index 8a13fb8a..b83b0bb4 100644 --- a/common/Sections.mli +++ b/common/Sections.mli @@ -47,5 +47,5 @@ val use_section_for: AST.ident -> string -> bool val for_variable: Env.t -> AST.ident -> C.typ -> bool -> section_name * access_mode -val for_function: Env.t -> AST.ident -> C.typ -> section_name list +val for_function: Env.t -> AST.ident -> C.attributes -> section_name list val for_stringlit: unit -> section_name diff --git a/cparser/Cprint.ml b/cparser/Cprint.ml index 2a110104..0a927873 100644 --- a/cparser/Cprint.ml +++ b/cparser/Cprint.ml @@ -142,13 +142,14 @@ let rec dcl ?(pp_indication=true) pp ty n = dcl pp t n' | TArray(t, sz, a) -> let n' pp = + n pp; begin match a with - | [] -> n pp - | _ -> fprintf pp " (%a%t)" attributes a n + | [] -> fprintf pp "[" + | _ -> fprintf pp "[%a " attributes a end; begin match sz with - | None -> fprintf pp "[]" - | Some i -> fprintf pp "[%Ld]" i + | None -> fprintf pp "]" + | Some i -> fprintf pp "%Ld]" i end in dcl pp t n' | TFun(tres, args, vararg, a) -> @@ -156,10 +157,8 @@ let rec dcl ?(pp_indication=true) pp ty n = 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; + attributes pp a; + n pp; fprintf pp "("; if pp_indication then fprintf pp "@[<hov 0>"; begin match args with diff --git a/cparser/Cutil.ml b/cparser/Cutil.ml index 9f893fb0..8a59c147 100644 --- a/cparser/Cutil.ml +++ b/cparser/Cutil.ml @@ -37,6 +37,15 @@ module IdentMap = Map.Make(Ident) (* Operations on attributes *) +(* Normalize the name of an attribute, removing starting and trailing '__' *) + +let re_normalize_attrname = Str.regexp "^__\\(.*\\)__$" + +let normalize_attrname a = + if Str.string_match re_normalize_attrname a 0 + then Str.matched_group 1 a + else a + (* Lists of attributes are kept sorted in increasing order *) let rec add_attributes (al1: attributes) (al2: attributes) = @@ -83,18 +92,35 @@ let rec remove_custom_attributes (names: string list) (al: attributes) = | a :: tl -> a :: remove_custom_attributes names tl +(* Classification of attributes *) + +type attribute_class = + | Attr_name (* Attribute applies to the names being declared *) + | Attr_type (* Attribute applies to types *) + | Attr_struct (* Attribute applies to struct, union and enum *) + | Attr_function (* Attribute applies to function types and decls *) + | Attr_unknown (* Unknown attribute *) + +let attr_class : (string, attribute_class) Hashtbl.t = Hashtbl.create 32 + +let declare_attribute name cls = + Hashtbl.replace attr_class (normalize_attrname name) cls + +let declare_attributes l = + List.iter (fun (n,c) -> declare_attribute n c) l + +let class_of_attribute = function + | AConst | AVolatile | ARestrict | AAlignas _ -> Attr_type + | Attr(name, args) -> + try Hashtbl.find attr_class (normalize_attrname name) + with Not_found -> Attr_unknown + (* Is an attribute a ISO C standard attribute? *) let attr_is_standard = function | AConst | AVolatile | ARestrict -> true | AAlignas _ | Attr _ -> false -(* Is an attribute type-related (true) or variable-related (false)? *) - -let attr_is_type_related = function - | Attr(("packed" | "__packed__"), _) -> true - | _ -> false - (* Is an attribute applicable to a whole array (true) or only to array elements (false)? *) diff --git a/cparser/Cutil.mli b/cparser/Cutil.mli index 5e560e44..4eaa9e4a 100644 --- a/cparser/Cutil.mli +++ b/cparser/Cutil.mli @@ -52,15 +52,32 @@ val erase_attributes_type : Env.t -> typ -> typ (* Erase the attributes of the given type. *) val change_attributes_type : Env.t -> (attributes -> attributes) -> typ -> typ (* Apply the given function to the top-level attributes of the given type *) -val attr_is_type_related: attribute -> bool - (* Is an attribute type-related (true) or variable-related (false)? *) + +type attribute_class = + | Attr_name (* Attribute applies to the names being declared *) + | Attr_type (* Attribute applies to types *) + | Attr_struct (* Attribute applies to struct, union and enum *) + | Attr_function (* Attribute applies to function types and decls *) + | Attr_unknown (* Not a declared attribute *) + +val declare_attribute: string -> attribute_class -> unit +val declare_attributes: (string * attribute_class) list -> unit + (* Register the given custom attribute names with the given classes. *) +val class_of_attribute: attribute -> attribute_class + (* Return the class of the given attribute. Standard attributes + have class [Attr_type]. Custom attributes have the class that + was given to them using [declare_attribute], or [Attr_unknown] + if not declared. *) val attr_inherited_by_members: attribute -> bool (* Is an attribute of a composite inherited by members of the composite? *) + + val strip_attributes_type: typ -> attribute list -> typ (* Remove all attributes from the given type that are not contained in the list *) val strip_last_attribute: typ -> attribute option * typ (* Remove the last top level attribute and return it *) + (* Type compatibility *) type attr_handling = diff --git a/cparser/Elab.ml b/cparser/Elab.ml index 9995be5c..69830122 100644 --- a/cparser/Elab.ml +++ b/cparser/Elab.ml @@ -474,6 +474,19 @@ let typespec_rank = function (* Don't change this *) let typespec_order t1 t2 = compare (typespec_rank t1) (typespec_rank t2) +(* Auxiliary for type declarator elaboration. Remove the non-type-related + attributes from the given type and return those attributes separately. + If the type is a function type, keep function-related attributes + attached to the type. *) + +let get_nontype_attrs env ty = + let to_be_removed a = + match class_of_attribute a with + | Attr_type -> false + | Attr_function -> not (is_function_type env ty) + | _ -> true in + let nta = List.filter to_be_removed (attributes_of_type env ty) in + (remove_attributes_type env nta ty, nta) (* Elaboration of a type specifier. Returns 5-tuple: (storage class, "inline" flag, "typedef" flag, elaborated type, new env) @@ -518,14 +531,15 @@ let rec elab_specifier keep_ty ?(only = false) loc env specifier = let simple ty = (!sto, !inline, !noreturn ,!typedef, add_attributes_type !attr ty, env) in - (* As done in CIL, partition !attr into type-related attributes, + (* As done in CIL, partition !attr into struct-related attributes, which are returned, and other attributes, which are left in !attr. - The returned type-related attributes are applied to the + The returned struct-related attributes are applied to the struct/union/enum being defined. - The leftover non-type-related attributes will be applied + The leftover non-struct-related attributes will be applied to the variable being defined. *) - let get_type_attrs () = - let (ta, nta) = List.partition attr_is_type_related !attr in + let get_struct_attrs () = + let (ta, nta) = + List.partition (fun a -> class_of_attribute a = Attr_struct) !attr in attr := nta; ta in @@ -584,21 +598,21 @@ let rec elab_specifier keep_ty ?(only = false) loc env specifier = | [Cabs.Tstruct_union(STRUCT, id, optmembers, a)] -> let a' = - add_attributes (get_type_attrs()) (elab_attributes env a) in + add_attributes (get_struct_attrs()) (elab_attributes env a) in let (id', env') = elab_struct_or_union keep_ty only Struct loc id optmembers a' env in (!sto, !inline, !noreturn, !typedef, TStruct(id', !attr), env') | [Cabs.Tstruct_union(UNION, id, optmembers, a)] -> let a' = - add_attributes (get_type_attrs()) (elab_attributes env a) in + add_attributes (get_struct_attrs()) (elab_attributes env a) in let (id', env') = elab_struct_or_union keep_ty only Union loc id optmembers a' env in (!sto, !inline, !noreturn, !typedef, TUnion(id', !attr), env') | [Cabs.Tenum(id, optmembers, a)] -> let a' = - add_attributes (get_type_attrs()) (elab_attributes env a) in + add_attributes (get_struct_attrs()) (elab_attributes env a) in let (id', env') = elab_enum only loc id optmembers a' env in (!sto, !inline, !noreturn, !typedef, TEnum(id', !attr), env') @@ -631,7 +645,8 @@ and elab_type_declarator keep_ty loc env ty kr_ok = function | Cabs.JUSTBASE -> ((ty, None), env) | Cabs.ARRAY(d, cv_specs, sz) -> - let a = elab_cvspecs env cv_specs in + let (ty, a) = get_nontype_attrs env ty in + let a = add_attributes a (elab_cvspecs env cv_specs) in let sz' = match sz with | None -> @@ -649,22 +664,25 @@ and elab_type_declarator keep_ty loc env ty kr_ok = function Some 1L in (* produces better error messages later *) elab_type_declarator keep_ty loc env (TArray(ty, sz', a)) kr_ok d | Cabs.PTR(cv_specs, d) -> - let a = elab_cvspecs env cv_specs in + let (ty, a) = get_nontype_attrs env ty in + let a = add_attributes a (elab_cvspecs env cv_specs) in elab_type_declarator keep_ty loc env (TPtr(ty, a)) kr_ok d | Cabs.PROTO(d, (params, vararg)) -> elab_return_type loc env ty; + let (ty, a) = get_nontype_attrs env ty in let params',env' = elab_parameters keep_ty env params in let env = if keep_ty then Env.add_types env env' else env in - elab_type_declarator keep_ty loc env (TFun(ty, Some params', vararg, [])) kr_ok d + elab_type_declarator keep_ty loc env (TFun(ty, Some params', vararg, a)) kr_ok d | Cabs.PROTO_OLD(d, params) -> elab_return_type loc env ty; + let (ty, a) = get_nontype_attrs env ty in match params with | [] -> - elab_type_declarator keep_ty loc env (TFun(ty, None, false, [])) kr_ok d + elab_type_declarator keep_ty loc env (TFun(ty, None, false, a)) kr_ok d | _ -> if not kr_ok || d <> Cabs.JUSTBASE then fatal_error loc "illegal old-style K&R function definition"; - ((TFun(ty, None, false, []), Some params), env) + ((TFun(ty, None, false, a), Some params), env) (* Elaboration of parameters in a prototype *) @@ -738,12 +756,14 @@ and elab_init_name_group keep_ty loc env (spec, namelist) = let a = elab_attributes env attr in if inl && not (is_function_type env ty) then error loc "'inline' can only appear on functions"; - if noret then begin - warning loc Celeven_extension "_Noreturn functions are a C11 extension"; - if not (is_function_type env ty) then - error loc "'_Noreturn' can only appear on functions"; - end; - ((id, add_attributes_type a ty, init), env1) in + let a' = + if noret then begin + warning loc Celeven_extension "_Noreturn functions are a C11 extension"; + if not (is_function_type env ty) then + error loc "'_Noreturn' can only appear on functions"; + add_attributes [Attr("noreturn",[])] a + end else a in + ((id, add_attributes_type a' ty, init), env1) in (mmap elab_one_name env' namelist, sto, tydef) (* Elaboration of a field group *) @@ -2328,17 +2348,19 @@ let elab_fundef env spec name defs body loc = { sdesc = Sblock (List.map mkdecl extra_decls @ [body2]); sloc = no_loc } end in - if noret then begin + (* Handling of _Noreturn and of attribute("noreturn") *) + if noret then warning loc Celeven_extension "_Noreturn functions are a C11 extension"; - if contains_return body1 then - warning loc Invalid_noreturn "function '%s' declared 'noreturn' should not return" s; - end; + if (noret || find_custom_attributes ["noreturn"; "__noreturn__"] attr <> []) + && contains_return body1 then + warning loc Invalid_noreturn "function '%s' declared 'noreturn' should not return" s; (* Build and emit function definition *) let fn = { fd_storage = sto1; fd_inline = inline; fd_name = fun_id; - fd_attrib = attr; + fd_attrib = if noret then add_attributes [Attr("noreturn",[])] attr + else attr; fd_ret = ty_ret; fd_params = params; fd_vararg = vararg; diff --git a/cparser/GCC.ml b/cparser/GCC.ml index f7f64a4e..010d12f3 100644 --- a/cparser/GCC.ml +++ b/cparser/GCC.ml @@ -13,7 +13,7 @@ (* *) (* *********************************************************************) -(* GCC built-ins *) +(* GCC built-ins and attributes *) open C open Cutil @@ -221,3 +221,25 @@ let builtins = { "__builtin_va_copy", (voidType, [ voidPtrType; voidPtrType ], false) ] } + +let attributes = [ (* a subset of those of GCC 5 *) + (* type-related *) + ("aligned", Attr_type); ("may_alias", Attr_type); ("visibility", Attr_type); + (* struct-related *) + ("packed", Attr_struct); ("designated_init", Attr_struct); + (* function-related *) + ("cdecl", Attr_function); ("stdcall", Attr_function); + ("fastcall", Attr_function); ("thiscall", Attr_function); + ("const", Attr_function); ("noreturn", Attr_name); + (* name-related *) + ("cleanup", Attr_name); ("common", Attr_name); ("nocommon", Attr_name); + ("deprecated", Attr_name); ("section", Attr_name); + ("shared", Attr_name); ("tls_model", Attr_name); ("unused", Attr_name); + ("used", Attr_name); ("weak", Attr_name); + ("dllimport", Attr_name); ("dllexport", Attr_name); + ("alway_inline", Attr_name); ("gnu_inline", Attr_name); + ("artificial", Attr_name); ("flatten", Attr_name); + ("error", Attr_name); ("warning", Attr_name); + ("constructor", Attr_name); ("destructor", Attr_name); + ("externally_visible", Attr_name); ("interrupt", Attr_name) +] diff --git a/cparser/GCC.mli b/cparser/GCC.mli index 76f40372..f26d12df 100644 --- a/cparser/GCC.mli +++ b/cparser/GCC.mli @@ -13,6 +13,7 @@ (* *) (* *********************************************************************) -(* GCC built-ins *) +(* GCC built-ins and attributes *) val builtins: Builtins.t +val attributes: (string * Cutil.attribute_class) list diff --git a/driver/Driver.ml b/driver/Driver.ml index 3219b7b7..9d5ed3b3 100755 --- a/driver/Driver.ml +++ b/driver/Driver.ml @@ -540,6 +540,7 @@ let _ = | _ -> assert false end; Builtins.set C2C.builtins; + Cutil.declare_attributes C2C.attributes; CPragmas.initialize(); parse_cmdline cmdline_actions; DebugInit.init (); (* Initialize the debug functions *) diff --git a/test/regression/attribs1.c b/test/regression/attribs1.c index 808610b7..0650b189 100644 --- a/test/regression/attribs1.c +++ b/test/regression/attribs1.c @@ -24,7 +24,7 @@ __attribute((__section__("myconst"))) const int e = 12; const char filler4 = 1; __attribute((__section__("myconst"))) const int f = 34; -__attribute((__section__("mycode"))) int myfunc(int x) { return x + 1; } +__attribute((__section__("mycode"))) int * myfunc(int * x) { return x + 1; } /* Alignment with typedefs and structs */ |