+2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * sem_ch7.adb (Entity_Table_Size): Change to nearest prime number.
+
+2017-09-06 Yannick Moy <moy@adacore.com>
+
+ * sem_warn.adb: Minor refactoring.
+
+2017-09-06 Ed Schonberg <schonberg@adacore.com>
+
+ * einfo.ads, einfo.adb (Get_Classwwide_Pragma): New utility,
+ to retrieve the inherited classwide precondition/postcondition
+ of a subprogram.
+ * freeze.adb (Freeze_Entity): Use Get_Classwide_Pragma when
+ freezing a subprogram, to complete the generation of the
+ corresponding checking code.
+
+2017-09-06 Eric Botcazou <ebotcazou@adacore.com>
+
+ * inline.adb (Analyze_Inlined_Bodies): Remove restriction on
+ loading of parent body with a with clause for the main unit.
+ * gcc-interface/decl.c (defer_limited_with_list): Document
+ new usage.
+ (gnat_to_gnu_entity) <E_Access_Type>: Handle
+ completed Taft Amendment types declared in external units like
+ types from limited with clauses. Adjust final processing of
+ defer_limited_with_list accordingly.
+
+2017-09-06 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_util.adb (Is_Controlled_Indexing): New routine.
+ (Is_Displace_Call): Use routine Strip to remove indirections.
+ (Is_Displacement_Of_Object_Or_Function_Result): Code clean up. Add a
+ missing case of controlled generalized indexing.
+ (Is_Source_Object): Use routine Strip to remove indirections.
+ (Strip): New routine.
+
+2017-09-06 Bob Duff <duff@adacore.com>
+
+ * sysdep.c (__gnat_has_cap_sys_nice): If HAVE_CAPABILITY is defined,
+ we include the proper header. Otherwise, we just declare the necessary
+ things from the capabilities library. This is so we can build on
+ machines without that library, while still enabling that library.
+ At run time, we're using weak symbols, so __gnat_has_cap_sys_nice will
+ simply return 0 if the library is not present, or not included
+ in the link.
+
+2017-09-06 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * exp_dbug.adb (Debug_Renaming_Declaration): Do not create an encoding
+ for renamings that involve function calls in prefix form.
+
+2017-09-06 Bob Duff <duff@adacore.com>
+
+ * sem_ch3.adb (Analyze_Subtype_Declaration):
+ Set Has_Delayed_Freeze on a subtype of an incomplete type.
+
+2017-09-06 Pierre-Marie de Rodat <derodat@adacore.com>
+
+ * par_sco.adb (Extend_Statement_Sequence): When the accept statement
+ has no parameter specification and no entry index, use the entry name
+ as the end of the generated SCO statement.
+
2017-09-06 Steve Baird <baird@adacore.com>
* exp_util.adb (Side_Effect_Free): For CodePeer (only) treat
return Empty;
end Get_Pragma;
+ --------------------------
+ -- Get_Classwide_Pragma --
+ --------------------------
+
+ function Get_Classwide_Pragma
+ (E : Entity_Id;
+ Id : Pragma_Id) return Node_Id
+ is
+ Item : Node_Id;
+ Items : Node_Id;
+
+ begin
+ Items := Contract (E);
+ if No (Items) then
+ return Empty;
+ end if;
+
+ Item := Pre_Post_Conditions (Items);
+
+ while Present (Item) loop
+ if Nkind (Item) = N_Pragma
+ and then Get_Pragma_Id (Pragma_Name_Unmapped (Item)) = Id
+ and then Class_Present (Item)
+ then
+ return Item;
+ else
+ Item := Next_Pragma (Item);
+ end if;
+ end loop;
+
+ return Empty;
+ end Get_Classwide_Pragma;
+
--------------------------------------
-- Get_Record_Representation_Clause --
--------------------------------------
-- Test_Case
-- Volatile_Function
+ function Get_Classwide_Pragma
+ (E : Entity_Id;
+ Id : Pragma_Id) return Node_Id;
+ -- Examine Rep_Item chain to locate a classwide pre- or postcondition
+ -- of a primitive operation. Returns Empty if not present.
+
function Get_Record_Representation_Clause (E : Entity_Id) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for a record
-- representation clause, and if found, returns it. Returns Empty
when N_Selected_Component =>
declare
- First_Bit : constant Uint :=
- Normalized_First_Bit
- (Entity (Selector_Name (Ren)));
+ Sel_Id : constant Entity_Id :=
+ Entity (Selector_Name (Ren));
+ First_Bit : Uint;
begin
+ -- If the renaming involves a call to a primitive function,
+ -- we are out of the scope of renaming encodings. We will
+ -- very likely create a variable to hold the renamed value
+ -- anyway, so the renaming entity will be available in
+ -- debuggers.
+
+ exit when not Ekind_In (Sel_Id, E_Component, E_Discriminant);
+
+ First_Bit := Normalized_First_Bit (Sel_Id);
Enable :=
Enable
or else Is_Packed
(Obj_Id : Entity_Id) return Boolean
is
function Is_Controlled_Function_Call (N : Node_Id) return Boolean;
- -- Determine if particular node denotes a controlled function call. The
- -- call may have been heavily expanded.
+ -- Determine whether node N denotes a controlled function call
+
+ function Is_Controlled_Indexing (N : Node_Id) return Boolean;
+ -- Determine whether node N denotes a generalized indexing form which
+ -- involves a controlled result.
function Is_Displace_Call (N : Node_Id) return Boolean;
- -- Determine whether a particular node is a call to Ada.Tags.Displace.
- -- The call might be nested within other actions such as conversions.
+ -- Determine whether node N denotes a call to Ada.Tags.Displace
function Is_Source_Object (N : Node_Id) return Boolean;
-- Determine whether a particular node denotes a source object
+ function Strip (N : Node_Id) return Node_Id;
+ -- Examine arbitrary node N by stripping various indirections and return
+ -- the "real" node.
+
---------------------------------
-- Is_Controlled_Function_Call --
---------------------------------
function Is_Controlled_Function_Call (N : Node_Id) return Boolean is
- Expr : Node_Id := Original_Node (N);
+ Expr : Node_Id;
begin
-- When a function call appears in Object.Operation format, the
-- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
-- N_Selected_Component
+ Expr := Original_Node (N);
loop
if Nkind (Expr) = N_Function_Call then
Expr := Name (Expr);
and then Needs_Finalization (Etype (Entity (Expr)));
end Is_Controlled_Function_Call;
+ ----------------------------
+ -- Is_Controlled_Indexing --
+ ----------------------------
+
+ function Is_Controlled_Indexing (N : Node_Id) return Boolean is
+ Expr : constant Node_Id := Original_Node (N);
+
+ begin
+ return
+ Nkind (Expr) = N_Indexed_Component
+ and then Present (Generalized_Indexing (Expr))
+ and then Needs_Finalization (Etype (Expr));
+ end Is_Controlled_Indexing;
+
----------------------
-- Is_Displace_Call --
----------------------
function Is_Displace_Call (N : Node_Id) return Boolean is
- Call : Node_Id;
+ Call : constant Node_Id := Strip (N);
begin
- -- Strip various actions which may precede a call to Displace
-
- Call := N;
- loop
- if Nkind (Call) = N_Explicit_Dereference then
- Call := Prefix (Call);
-
- elsif Nkind_In (Call, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
- then
- Call := Expression (Call);
-
- else
- exit;
- end if;
- end loop;
-
return
Present (Call)
and then Nkind (Call) = N_Function_Call
----------------------
function Is_Source_Object (N : Node_Id) return Boolean is
- Obj : Node_Id;
+ Obj : constant Node_Id := Strip (N);
begin
- -- Strip various actions which may be associated with the object
+ return
+ Present (Obj)
+ and then Comes_From_Source (Obj)
+ and then Nkind (Obj) in N_Has_Entity
+ and then Is_Object (Entity (Obj));
+ end Is_Source_Object;
+
+ -----------
+ -- Strip --
+ -----------
+
+ function Strip (N : Node_Id) return Node_Id is
+ Result : Node_Id;
- Obj := N;
+ begin
+ Result := N;
loop
- if Nkind (Obj) = N_Explicit_Dereference then
- Obj := Prefix (Obj);
+ if Nkind (Result) = N_Explicit_Dereference then
+ Result := Prefix (Result);
- elsif Nkind_In (Obj, N_Type_Conversion,
- N_Unchecked_Type_Conversion)
+ elsif Nkind_In (Result, N_Type_Conversion,
+ N_Unchecked_Type_Conversion)
then
- Obj := Expression (Obj);
+ Result := Expression (Result);
else
exit;
end if;
end loop;
- return
- Present (Obj)
- and then Nkind (Obj) in N_Has_Entity
- and then Is_Object (Entity (Obj))
- and then Comes_From_Source (Obj);
- end Is_Source_Object;
+ return Result;
+ end Strip;
-- Local variables
- Decl : constant Node_Id := Parent (Obj_Id);
+ Obj_Decl : constant Node_Id := Declaration_Node (Obj_Id);
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
- Orig_Decl : constant Node_Id := Original_Node (Decl);
+ Orig_Decl : constant Node_Id := Original_Node (Obj_Decl);
+ Orig_Expr : Node_Id;
-- Start of processing for Is_Displacement_Of_Object_Or_Function_Result
-- Obj : CW_Type := Function_Call (...);
- -- rewritten into:
+ -- is rewritten into:
- -- Tmp : ... := Function_Call (...)'reference;
- -- Obj : CW_Type renames (... Ada.Tags.Displace (Tmp));
+ -- Temp : ... := Function_Call (...)'reference;
+ -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
-- where the return type of the function and the class-wide type require
-- dispatch table pointer displacement.
-- Case 2:
+ -- Obj : CW_Type := Container (...);
+
+ -- is rewritten into:
+
+ -- Temp : ... := Function_Call (Container, ...)'reference;
+ -- Obj : CW_Type renames (... Ada.Tags.Displace (Temp));
+
+ -- where the container element type and the class-wide type require
+ -- dispatch table pointer dispacement.
+
+ -- Case 3:
+
-- Obj : CW_Type := Src_Obj;
- -- rewritten into:
+ -- is rewritten into:
-- Obj : CW_Type renames (... Ada.Tags.Displace (Src_Obj));
-- where the type of the source object and the class-wide type require
-- dispatch table pointer displacement.
- return
- Nkind (Decl) = N_Object_Renaming_Declaration
- and then Nkind (Orig_Decl) = N_Object_Declaration
- and then Comes_From_Source (Orig_Decl)
- and then Is_Class_Wide_Type (Obj_Typ)
- and then Is_Displace_Call (Renamed_Object (Obj_Id))
- and then
- (Is_Controlled_Function_Call (Expression (Orig_Decl))
- or else Is_Source_Object (Expression (Orig_Decl)));
+ if Nkind (Obj_Decl) = N_Object_Renaming_Declaration
+ and then Is_Class_Wide_Type (Obj_Typ)
+ and then Is_Displace_Call (Renamed_Object (Obj_Id))
+ and then Nkind (Orig_Decl) = N_Object_Declaration
+ and then Comes_From_Source (Orig_Decl)
+ then
+ Orig_Expr := Expression (Orig_Decl);
+
+ return
+ Is_Controlled_Function_Call (Orig_Expr)
+ or else Is_Controlled_Indexing (Orig_Expr)
+ or else Is_Source_Object (Orig_Expr);
+ end if;
+
+ return False;
end Is_Displacement_Of_Object_Or_Function_Result;
------------------------------
New_Prag : Node_Id;
begin
- A_Pre := Get_Pragma (Par_Prim, Pragma_Precondition);
- if Present (A_Pre) and then Class_Present (A_Pre) then
+ A_Pre := Get_Classwide_Pragma (Par_Prim, Pragma_Precondition);
+ if Present (A_Pre) then
New_Prag := New_Copy_Tree (A_Pre);
Build_Class_Wide_Expression
(Prag => New_Prag,
end if;
end if;
- A_Post := Get_Pragma (Par_Prim, Pragma_Postcondition);
+ A_Post := Get_Classwide_Pragma (Par_Prim, Pragma_Postcondition);
- if Present (A_Post) and then Class_Present (A_Post) then
+ if Present (A_Post) then
New_Prag := New_Copy_Tree (A_Post);
Build_Class_Wide_Expression
(Prag => New_Prag,
To_Node := Last (Parameter_Specifications (N));
elsif Present (Entry_Index (N)) then
To_Node := Entry_Index (N);
+ else
+ To_Node := Entry_Direct_Name (N);
end if;
when N_Case_Statement =>
Conditional_Delay (Id, T);
end if;
+ -- If we have a subtype of an incomplete type whose full type is a
+ -- derived numeric type, we need to have a freeze node for the subtype.
+ -- Otherwise gigi will complain while computing the (static) bounds of
+ -- the subtype.
+
+ if Is_Itype (T)
+ and then Is_Elementary_Type (Id)
+ and then Etype (Id) /= Id
+ then
+ declare
+ Partial : constant Entity_Id :=
+ Incomplete_Or_Partial_View (First_Subtype (Id));
+ begin
+ if Present (Partial)
+ and then Ekind (Partial) = E_Incomplete_Type
+ then
+ Set_Has_Delayed_Freeze (Id);
+ end if;
+ end;
+ end if;
+
-- Check that Constraint_Error is raised for a scalar subtype indication
-- when the lower or upper bound of a non-null range lies outside the
-- range of the type mark.
-- Analyze_Package_Body_Helper Data and Subprograms --
------------------------------------------------------
- Entity_Table_Size : constant := 4096;
+ Entity_Table_Size : constant := 4093;
-- Number of headers in hash table
subtype Entity_Header_Num is Integer range 0 .. Entity_Table_Size - 1;
-- an expression with actions.
UR := Original_Node (UR);
- while Nkind_In (UR, N_Attribute_Reference,
- N_Expression_With_Actions,
+ loop
+ if Nkind_In (UR, N_Expression_With_Actions,
N_Qualified_Expression,
N_Type_Conversion)
- loop
- if Nkind (UR) = N_Attribute_Reference then
+ then
+ UR := Expression (UR);
+
+ elsif Nkind (UR) = N_Attribute_Reference then
UR := Prefix (UR);
+
else
- UR := Expression (UR);
+ exit;
end if;
end loop;
#if defined (__linux__)
-/* HAVE_CAPABILITY is defined if sys/capability.h exists on the system where
- this is being compiled.
+/* Note well: If this code is modified, it should be tested by hand,
+ because automated testing doesn't exercise it.
+*/
+
+/* HAVE_CAPABILITY is supposed to be defined if sys/capability.h exists on the
+ system where this is being compiled. If this macro is defined, we #include
+ the header. Otherwise we have the relevant declarations textually here.
*/
#if defined (HAVE_CAPABILITY)
#include <sys/capability.h>
+#else
-/* Note well: If this code is modified, it should be tested by hand,
- because automated testing doesn't exercise it.
-*/
+/* HAVE_CAPABILITY is not defined, so sys/capability.h does might not exist. */
+
+typedef struct _cap_struct *cap_t;
+typedef enum {
+ CAP_CLEAR=0,
+ CAP_SET=1
+} cap_flag_value_t;
+#define CAP_SYS_NICE 23
+typedef enum {
+ CAP_EFFECTIVE=0, /* Specifies the effective flag */
+ CAP_PERMITTED=1, /* Specifies the permitted flag */
+ CAP_INHERITABLE=2 /* Specifies the inheritable flag */
+} cap_flag_t;
+
+typedef int cap_value_t;
+
+extern cap_t cap_get_proc(void);
+extern int cap_get_flag(cap_t, cap_value_t, cap_flag_t, cap_flag_value_t *);
+extern int cap_free(void *);
+
+#endif
/* __gnat_has_cap_sys_nice returns 1 if the current process has the
CAP_SYS_NICE capability. This capability is necessary to use the
symbols will be 0, and __gnat_has_cap_sys_nice will return 0.
*/
-static cap_t cap_get_proc_weak() __attribute__ ((weakref ("cap_get_proc")));
-static int cap_get_flag_weak() __attribute__ ((weakref ("cap_get_flag")));
-static int cap_free_weak() __attribute__ ((weakref ("cap_free")));
+static cap_t cap_get_proc_weak(void)
+ __attribute__ ((weakref ("cap_get_proc")));
+static int cap_get_flag_weak(cap_t, cap_value_t, cap_flag_t, cap_flag_value_t *)
+ __attribute__ ((weakref ("cap_get_flag")));
+static int cap_free_weak(void *)
+ __attribute__ ((weakref ("cap_free")));
int
__gnat_has_cap_sys_nice () {
return 0;
cap_t caps = cap_get_proc_weak();
- cap_flag_value_t value;
-
if (caps == NULL)
return 0;
+ cap_flag_value_t value;
+
if (cap_get_flag_weak(caps, CAP_SYS_NICE, CAP_EFFECTIVE, &value) == -1)
return 0;
return 0;
}
-
-#else
-
-/* HAVE_CAPABILITY is not defined, so sys/capability.h does not exist, so
- simply indicate that the current process does not have the CAP_SYS_NICE
- capability.
-*/
-
-int
-__gnat_has_cap_sys_nice () {
- return 0;
-}
-
-#endif
#endif
#ifdef __ANDROID__
projects / gcc.git / commitdiff