+2017-09-08 Arnaud Charlet <charlet@adacore.com>
+
+ * sem_util.ads, sem_util.adb (Is_CCT_Instance): moved from
+ sem_prag.adb to make it available for GNATprove; for concurrent
+ types replace custom scope climbing with Scope_Same_Or_Within; for
+ single concurrent objects add scope climbing (with Scope_Within),
+ which was not there (that's the primary semantic change of this
+ commit); also, when comparing a single concurrent object with
+ its corresponding concurrent type rely on equality of types,
+ not of objects (because that's simpler to code).
+ * sem_prag.adb (Is_CCT_Instance): lifted to sem_util.ads.
+ (Analyze_Global_Item): adjust special-casing of references to the
+ current instance of a concurrent unit in the Global contracts
+ of task types and single tasks objects; similar for references
+ in the protected operations and entries of protected types and
+ single protected objects (in all these cases the current instance
+ behaves as an implicit parameter and must not be mentioned in
+ the Global contract).
+
+2017-09-08 Arnaud Charlet <charlet@adacore.com>
+
+ * exp_ch6.adb (Expand_Call_Helper): Introduce temporary for
+ function calls returning a record within a subprogram call,
+ for C generation.
+
+2017-09-08 Ed Schonberg <schonberg@adacore.com>
+
+ * sem_ch8.adb (Find_Expanded_Name): Handle properly an expanded
+ name that designates the current instance of a child unit in its
+ own body and appears as the prefix of a reference to an entity
+ local to the child unit.
+ * exp_ch6.adb, freeze.adb, sem_ch3.adb, sem_prag.adb, sem_util.adb:
+ Minor reformatting.
+
+2017-09-08 Yannick Moy <moy@adacore.com>
+
+ * sem_res.adb (Resolve_Equality_Op): Do not warn on comparisons that
+ may be intentional.
+
+2017-09-08 Tristan Gingold <gingold@adacore.com>
+
+ * sem_warn.adb (Check_Unused_Withs): Remove test that disabled
+ warnings on internal units in configurable run time mode.
+
2017-09-08 Bob Duff <duff@adacore.com>
* sem_ch3.adb (Build_Derived_Private_Type): Inherit
end;
end if;
- -- When generating C code, transform a function call that returns a
- -- constrained array type into procedure form.
-
if Modify_Tree_For_C
and then Nkind (Call_Node) = N_Function_Call
and then Is_Entity_Name (Name (Call_Node))
- and then Rewritten_For_C (Ultimate_Alias (Entity (Name (Call_Node))))
then
- -- For internally generated calls ensure that they reference the
- -- entity of the spec of the called function (needed since the
- -- expander may generate calls using the entity of their body).
- -- See for example Expand_Boolean_Operator().
-
- if not (Comes_From_Source (Call_Node))
- and then Nkind (Unit_Declaration_Node
- (Ultimate_Alias (Entity (Name (Call_Node))))) =
- N_Subprogram_Body
- then
- Set_Entity (Name (Call_Node),
- Corresponding_Function
- (Corresponding_Procedure
- (Ultimate_Alias (Entity (Name (Call_Node))))));
- end if;
+ declare
+ Func_Id : constant Entity_Id :=
+ Ultimate_Alias (Entity (Name (Call_Node)));
+ begin
+ -- When generating C code, transform a function call that returns
+ -- a constrained array type into procedure form.
- Rewrite_Function_Call_For_C (Call_Node);
- return;
+ if Rewritten_For_C (Func_Id) then
+
+ -- For internally generated calls ensure that they reference
+ -- the entity of the spec of the called function (needed since
+ -- the expander may generate calls using the entity of their
+ -- body). See for example Expand_Boolean_Operator().
+
+ if not (Comes_From_Source (Call_Node))
+ and then Nkind (Unit_Declaration_Node (Func_Id)) =
+ N_Subprogram_Body
+ then
+ Set_Entity (Name (Call_Node),
+ Corresponding_Function
+ (Corresponding_Procedure (Func_Id)));
+ end if;
+
+ Rewrite_Function_Call_For_C (Call_Node);
+ return;
+
+ -- Also introduce a temporary for functions that return a record
+ -- called within another procedure or function call, since records
+ -- are passed by pointer in the generated C code, and we cannot
+ -- take a pointer from a subprogram call.
+
+ elsif Nkind (Parent (Call_Node)) in N_Subprogram_Call
+ and then Is_Record_Type (Etype (Func_Id))
+ then
+ declare
+ Temp_Id : constant Entity_Id := Make_Temporary (Loc, 'T');
+ Decl : Node_Id;
+
+ begin
+ -- Generate:
+ -- Temp : ... := Func_Call (...);
+
+ Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Temp_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Etype (Func_Id), Loc),
+ Expression =>
+ Make_Function_Call (Loc,
+ Name =>
+ New_Occurrence_Of (Func_Id, Loc),
+ Parameter_Associations =>
+ Parameter_Associations (Call_Node)));
+
+ Insert_Action (Parent (Call_Node), Decl);
+ Rewrite (Call_Node, New_Occurrence_Of (Temp_Id, Loc));
+ return;
+ end;
+ end if;
+ end;
end if;
-- First step, compute extra actuals, corresponding to any Extra_Formals
--------------------
function Freeze_Profile (E : Entity_Id) return Boolean is
- F_Type : Entity_Id;
- R_Type : Entity_Id;
- Warn_Node : Node_Id;
-
function Has_Incomplete_Component (T : Entity_Id) return Boolean;
- -- If a type includes a private component from an enclosing scope
- -- it cannot be frozen yet. This can happen in a package nested
- -- within another, when freezing an expression function whose
- -- profile depends on a type in some outer scope. Those types will
- -- be frozen at a later time in the enclosing unit.
+ -- If a type includes a private component from an enclosing scope it
+ -- cannot be frozen yet. This can happen in a package nested within
+ -- another, when freezing an expression function whose profile
+ -- depends on a type in some outer scope. Those types will be frozen
+ -- at a later time in the enclosing unit.
------------------------------
-- Has_Incomplete_Component --
while Present (Comp) loop
Comp_Typ := Etype (Comp);
+
if Ekind_In (Comp, E_Component, E_Discriminant)
and then Is_Private_Type (Comp_Typ)
and then No (Full_View (Comp_Typ))
then
return True;
end if;
+
Comp := Next_Entity (Comp);
end loop;
elsif Is_Array_Type (T) then
Comp_Typ := Component_Type (T);
- return Is_Private_Type (Comp_Typ)
- and then No (Full_View (Comp_Typ))
- and then In_Open_Scopes (Scope (Comp_Typ))
- and then Scope (Comp_Typ) /= Current_Scope;
+
+ return
+ Is_Private_Type (Comp_Typ)
+ and then No (Full_View (Comp_Typ))
+ and then In_Open_Scopes (Scope (Comp_Typ))
+ and then Scope (Comp_Typ) /= Current_Scope;
else
return False;
end if;
end Has_Incomplete_Component;
+ -- Local variables
+
+ F_Type : Entity_Id;
+ R_Type : Entity_Id;
+ Warn_Node : Node_Id;
+
+ -- Start of processing for Freeze_Profile
+
begin
-- Loop through formals
-- type, and from any interfaces.
Inherit_Rep_Item_Chain (Derived_Type, Parent_Type);
+
declare
Iface : Node_Id := First (Abstract_Interface_List (Derived_Type));
begin
-- addition the renamed entity may depend on the generic formals of
-- the enclosing generic.
- if Is_Actual and not Inside_A_Generic then
+ if Is_Actual and then not Inside_A_Generic then
Freeze_Before (N, Old_S);
Freeze_Actual_Profile;
Set_Has_Delayed_Freeze (New_S, False);
Candidate := Get_Full_View (Non_Limited_View (Id));
Is_New_Candidate := True;
+ -- An unusual case arises with a fully qualified name for an
+ -- entity local to a generic child unit package, within an
+ -- instantiation of that package. The name of the unit now
+ -- denotes the renaming created within the instance. This is
+ -- only relevant in an instance body, see below.
+
+ elsif Is_Generic_Instance (Scope (Id))
+ and then In_Open_Scopes (Scope (Id))
+ and then In_Instance_Body
+ and then Ekind (Scope (Id)) = E_Package
+ and then Ekind (Id) = E_Package
+ and then Renamed_Entity (Id) = Scope (Id)
+ then
+ Is_New_Candidate := True;
+
else
Is_New_Candidate := False;
end if;
end;
else
+ -- Might be worth specializing the case when the prefix
+ -- is a limited view.
+ -- ... not declared in limited view of...
+
Error_Msg_NE ("& not declared in&", N, Selector);
end if;
-- Determine whether dependency clause Clause is surrounded by extra
-- parentheses. If this is the case, issue an error message.
- function Is_CCT_Instance
- (Ref_Id : Entity_Id;
- Context_Id : Entity_Id) return Boolean;
- -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
- -- Global. Determine whether entity Ref_Id denotes the current instance of
- -- a concurrent type. Context_Id denotes the associated context where the
- -- pragma appears.
-
function Is_Unconstrained_Or_Tagged_Item (Item : Entity_Id) return Boolean;
-- Subsidiary to Collect_Subprogram_Inputs_Outputs and the analysis of
-- pragma Depends. Determine whether the type of dependency item Item is
-- formal parameter.
if Ekind (Item_Id) = E_Protected_Type then
- Error_Msg_Name_1 := Chars (Item_Id);
- SPARK_Msg_NE
- (Fix_Msg (Spec_Id, "global item of subprogram & "
- & "cannot reference current instance of protected "
- & "type %"), Item, Spec_Id);
- return;
+ if Scope (Spec_Id) = Item_Id then
+ Error_Msg_Name_1 := Chars (Item_Id);
+ SPARK_Msg_NE
+ (Fix_Msg (Spec_Id, "global item of subprogram & "
+ & "cannot reference current instance of "
+ & "protected type %"), Item, Spec_Id);
+ return;
+ end if;
-- Pragma [Refined_]Global associated with a task type
-- cannot mention the current instance of a task type
-- because the instance behaves as a formal parameter.
else pragma Assert (Ekind (Item_Id) = E_Task_Type);
- Error_Msg_Name_1 := Chars (Item_Id);
- SPARK_Msg_NE
- (Fix_Msg (Spec_Id, "global item of subprogram & "
- & "cannot reference current instance of task type "
- & "%"), Item, Spec_Id);
- return;
+ if Spec_Id = Item_Id then
+ Error_Msg_Name_1 := Chars (Item_Id);
+ SPARK_Msg_NE
+ (Fix_Msg (Spec_Id, "global item of subprogram & "
+ & "cannot reference current instance of task "
+ & "type %"), Item, Spec_Id);
+ return;
+ end if;
end if;
-- Otherwise the global item denotes a subtype mark that is
-- parameter.
if Is_Single_Protected_Object (Item_Id) then
- Error_Msg_Name_1 := Chars (Item_Id);
- SPARK_Msg_NE
- (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
- & "reference current instance of protected type %"),
- Item, Spec_Id);
- return;
+ if Scope (Spec_Id) = Etype (Item_Id) then
+ Error_Msg_Name_1 := Chars (Item_Id);
+ SPARK_Msg_NE
+ (Fix_Msg (Spec_Id, "global item of subprogram & "
+ & "cannot reference current instance of protected "
+ & "type %"), Item, Spec_Id);
+ return;
+ end if;
-- Pragma [Refined_]Global associated with a task type
-- cannot mention the current instance of a task type
-- because the instance behaves as a formal parameter.
else pragma Assert (Is_Single_Task_Object (Item_Id));
- Error_Msg_Name_1 := Chars (Item_Id);
- SPARK_Msg_NE
- (Fix_Msg (Spec_Id, "global item of subprogram & cannot "
- & "reference current instance of task type %"),
- Item, Spec_Id);
- return;
+ if Spec_Id = Item_Id then
+ Error_Msg_Name_1 := Chars (Item_Id);
+ SPARK_Msg_NE
+ (Fix_Msg (Spec_Id, "global item of subprogram & "
+ & "cannot reference current instance of task "
+ & "type %"), Item, Spec_Id);
+ return;
+ end if;
end if;
-- A formal object may act as a global item inside a generic
return Add_Config_Static_String (Arg);
end Is_Config_Static_String;
- ---------------------
- -- Is_CCT_Instance --
- ---------------------
-
- function Is_CCT_Instance
- (Ref_Id : Entity_Id;
- Context_Id : Entity_Id) return Boolean
- is
- S : Entity_Id;
- Typ : Entity_Id;
-
- begin
- -- When the reference denotes a single protected type, the context is
- -- either a protected subprogram or its body.
-
- if Is_Single_Protected_Object (Ref_Id) then
- Typ := Scope (Context_Id);
-
- return
- Ekind (Typ) = E_Protected_Type
- and then Present (Anonymous_Object (Typ))
- and then Anonymous_Object (Typ) = Ref_Id;
-
- -- When the reference denotes a single task type, the context is either
- -- the same type or if inside the body, the anonymous task type.
-
- elsif Is_Single_Task_Object (Ref_Id) then
- if Ekind (Context_Id) = E_Task_Type then
- return
- Present (Anonymous_Object (Context_Id))
- and then Anonymous_Object (Context_Id) = Ref_Id;
- else
- return Ref_Id = Context_Id;
- end if;
-
- -- Otherwise the reference denotes a protected or a task type. Climb the
- -- scope chain looking for an enclosing concurrent type that matches the
- -- referenced entity.
-
- else
- pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
-
- S := Current_Scope;
- while Present (S) and then S /= Standard_Standard loop
- if Ekind_In (S, E_Protected_Type, E_Task_Type)
- and then S = Ref_Id
- then
- return True;
- end if;
-
- S := Scope (S);
- end loop;
- end if;
-
- return False;
- end Is_CCT_Instance;
-
-------------------------------
-- Is_Elaboration_SPARK_Mode --
-------------------------------
Check_Restriction (No_Dispatching_Calls, N);
end if;
+ -- Only warn for redundant equality comparison to True for objects
+ -- (e.g. "X = True") and operations (e.g. "(X < Y) = True"). For
+ -- other expressions, it may be a matter of preference to write
+ -- "Expr = True" or "Expr".
+
if Warn_On_Redundant_Constructs
and then Comes_From_Source (N)
and then Comes_From_Source (R)
and then Is_Entity_Name (R)
and then Entity (R) = Standard_True
+ and then
+ ((Is_Entity_Name (L) and then Is_Object (Entity (L)))
+ or else
+ Nkind (L) in N_Op)
then
Error_Msg_N -- CODEFIX
("?r?comparison with True is redundant!", N);
Nod := Type_Definition (Parent (Typ));
end if;
- -- It's not the kind of type that can implement interfaces
+ -- Otherwise the type is of a kind which does not implement interfaces
else
return Empty_List;
Is_RTE (Root_Type (Under), RO_WW_Super_String));
end Is_Bounded_String;
+ ---------------------
+ -- Is_CCT_Instance --
+ ---------------------
+
+ function Is_CCT_Instance
+ (Ref_Id : Entity_Id;
+ Context_Id : Entity_Id) return Boolean
+ is
+ begin
+ pragma Assert
+ (Is_Entry (Context_Id)
+ or else
+ Ekind_In (Context_Id, E_Function,
+ E_Procedure,
+ E_Protected_Type,
+ E_Task_Type)
+ or else
+ Is_Single_Concurrent_Object (Context_Id));
+
+ -- When the reference denotes a single protected type, the context is
+ -- either a protected subprogram or its body.
+
+ if Is_Single_Protected_Object (Ref_Id) then
+ return Scope_Within (Context_Id, Etype (Ref_Id));
+
+ -- When the reference denotes a single task type, the context is either
+ -- the same type or if inside the body, the anonymous task object.
+
+ elsif Is_Single_Task_Object (Ref_Id) then
+ if Is_Single_Task_Object (Context_Id) then
+ return Context_Id = Ref_Id;
+
+ elsif Ekind (Context_Id) = E_Task_Type then
+ return Context_Id = Etype (Ref_Id);
+
+ else
+ return Scope_Within_Or_Same (Context_Id, Etype (Ref_Id));
+ end if;
+
+ else
+ pragma Assert (Ekind_In (Ref_Id, E_Protected_Type, E_Task_Type));
+
+ return Scope_Within_Or_Same (Context_Id, Ref_Id);
+ end if;
+ end Is_CCT_Instance;
+
-------------------------
-- Is_Child_Or_Sibling --
-------------------------
function Is_CPP_Constructor_Call (N : Node_Id) return Boolean;
-- Returns True if N is a call to a CPP constructor
+ function Is_CCT_Instance
+ (Ref_Id : Entity_Id;
+ Context_Id : Entity_Id) return Boolean;
+ -- Subsidiary to the analysis of pragmas [Refined_]Depends and [Refined_]
+ -- Global. Determine whether entity Ref_Id denotes the current instance of
+ -- a concurrent type. Context_Id denotes the associated context where the
+ -- pragma appears.
+
function Is_Child_Or_Sibling
(Pack_1 : Entity_Id;
Pack_2 : Entity_Id) return Boolean;
if not In_Extended_Main_Source_Unit (Cnode) then
return;
-
- -- In configurable run time mode, we remove the bodies of non-inlined
- -- subprograms, which may lead to spurious warnings, which are
- -- clearly undesirable.
-
- elsif Configurable_Run_Time_Mode
- and then Is_Predefined_Unit (Unit)
- then
- return;
end if;
-- Loop through context items in this unit
projects / gcc.git / commitdiff