then
declare
Ass : Node_Id := Empty;
+ Par : Node_Id := Parent (Call_Node);
begin
- if Nkind (Parent (Call_Node)) = N_Assignment_Statement then
- Ass := Parent (Call_Node);
+ -- Search for the LHS of an enclosing assignment statement to a
+ -- classwide type object (if present) and propagate the tag to
+ -- this function call.
+
+ while Nkind (Par) in N_Case_Expression
+ | N_Case_Expression_Alternative
+ | N_Explicit_Dereference
+ | N_If_Expression
+ | N_Qualified_Expression
+ | N_Unchecked_Type_Conversion
+ loop
+ if Nkind (Par) = N_Case_Expression_Alternative then
+ Par := Parent (Par);
+ end if;
- elsif Nkind (Parent (Call_Node)) = N_Qualified_Expression
- and then Nkind (Parent (Parent (Call_Node))) =
- N_Assignment_Statement
- then
- Ass := Parent (Parent (Call_Node));
+ exit when not Is_Tag_Indeterminate (Par);
- elsif Nkind (Parent (Call_Node)) = N_Explicit_Dereference
- and then Nkind (Parent (Parent (Call_Node))) =
- N_Assignment_Statement
- then
- Ass := Parent (Parent (Call_Node));
- end if;
+ Par := Parent (Par);
+ end loop;
- if Present (Ass)
- and then Is_Class_Wide_Type (Etype (Name (Ass)))
+ if Nkind (Par) = N_Assignment_Statement
+ and then Is_Class_Wide_Type (Etype (Name (Par)))
then
+ Ass := Par;
+
-- Move the error messages below to sem???
if Is_Access_Type (Etype (Call_Node)) then
Call_Node, Root_Type (Etype (Name (Ass))));
else
Propagate_Tag (Name (Ass), Call_Node);
+
+ -- Remember that the tag has been propagated to avoid
+ -- propagating it again, as part of the (bottom-up)
+ -- analysis of the enclosing assignment.
+
+ Set_Tag_Propagated (Name (Ass));
end if;
elsif Etype (Call_Node) /= Root_Type (Etype (Name (Ass))) then
else
Propagate_Tag (Name (Ass), Call_Node);
+
+ -- Remember that the tag has been propagated to avoid
+ -- propagating it again, as part of the (bottom-up)
+ -- analysis of the enclosing assignment.
+
+ Set_Tag_Propagated (Name (Ass));
end if;
-- The call will be rewritten as a dispatching call, and
-- No action needed if the dispatching call has been already expanded
- or else Is_Expanded_Dispatching_Call (Name (Call_Node))
+ or else Is_Expanded_Dispatching_Call (Call_Node)
then
return;
end if;
-- the generation of spurious warnings under ZFP run-time.
Analyze_And_Resolve (Call_Node, Call_Typ, Suppress => All_Checks);
+
+ Set_Is_Expanded_Dispatching_Call (Call_Node);
end Expand_Dispatching_Call;
---------------------------------
and then not Restriction_Active (No_Dispatching_Calls);
end Has_DT;
- ----------------------------------
- -- Is_Expanded_Dispatching_Call --
- ----------------------------------
-
- function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean is
- begin
- return Nkind (N) in N_Subprogram_Call
- and then Nkind (Name (N)) = N_Explicit_Dereference
- and then Is_Dispatch_Table_Entity (Etype (Name (N)));
- end Is_Expanded_Dispatching_Call;
-
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
function Has_CPP_Constructors (Typ : Entity_Id) return Boolean;
-- Returns true if the type has CPP constructors
- function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean;
- -- Returns true if N is the expanded code of a dispatching call
-
function Make_DT (Typ : Entity_Id) return List_Id;
-- Expand the declarations for the Dispatch Table of Typ
Is_Entry_Barrier_Function,
Is_Expanded_Build_In_Place_Call,
Is_Expanded_Constructor_Call,
+ Is_Expanded_Dispatching_Call,
Is_Expanded_Prefixed_Call,
Is_Folded_In_Parser,
Is_Generic_Contract_Pragma,
Suppress_Loop_Warnings,
Synchronized_Present,
Tagged_Present,
+ Tag_Propagated,
Target,
Call_Or_Target_Loop,
Target_Type,
Sm (Is_Controlling_Actual, Flag),
Sm (Is_Overloaded, Flag),
Sm (Is_Static_Expression, Flag),
+ Sm (Is_Expanded_Dispatching_Call, Flag),
Sm (Must_Not_Freeze, Flag),
Sm (Raises_Constraint_Error, Flag)));
Sm (Is_Elaboration_Warnings_OK_Node, Flag),
Sm (Is_SPARK_Mode_On_Node, Flag),
Sm (Original_Discriminant, Node_Id),
- Sm (Redundant_Use, Flag)));
+ Sm (Redundant_Use, Flag),
+ Sm (Tag_Propagated, Flag)));
Cc (N_Operator_Symbol, N_Direct_Name,
(Sy (Strval, String_Id)));
(Sy (Prefix, Node_Id),
Sm (Actual_Designated_Subtype, Node_Id),
Sm (Atomic_Sync_Required, Flag),
- Sm (Has_Dereference_Action, Flag)));
+ Sm (Has_Dereference_Action, Flag),
+ Sm (Tag_Propagated, Flag)));
Cc (N_Expression_With_Actions, N_Subexpr,
(Sy (Actions, List_Id, Default_No_List),
Sm (Do_Length_Check, Flag),
Sm (Do_Overflow_Check, Flag),
Sm (Float_Truncate, Flag),
+ Sm (Tag_Propagated, Flag),
Sm (Rounded_Result, Flag)));
Cc (N_Unchecked_Type_Conversion, N_Subexpr,
Sm (Cleanup_Actions, List_Id),
Sm (Exception_Junk, Flag),
Sm (Is_Abort_Block, Flag),
+ Sm (Is_Expanded_Dispatching_Call, Flag),
Sm (Is_Initialization_Block, Flag),
Sm (Is_Task_Master, Flag)));
if Is_Tag_Indeterminate (Rhs) then
if Is_Class_Wide_Type (T1) then
- Propagate_Tag (Lhs, Rhs);
+
+ -- No need to propagate the tag when the RHS has function calls
+ -- that already propagated it (see Expand_Call_Helper), or if
+ -- some error was reported analyzing RHS.
+
+ if not (Error_Posted (Rhs) or else Tag_Propagated (Lhs)) then
+ Propagate_Tag (Lhs, Rhs);
+ end if;
elsif Nkind (Rhs) = N_Function_Call
and then Is_Entity_Name (Name (Rhs))
then
return Is_Tag_Indeterminate (Prefix (Orig_Node));
+ -- An if-expression is tag-indeterminate if all of the dependent
+ -- expressions are tag-indeterminate (RM 4.5.7 (17/3)).
+
+ elsif Nkind (Orig_Node) = N_If_Expression then
+ declare
+ Cond : constant Node_Id := First (Expressions (Orig_Node));
+ Expr : Node_Id := Next (Cond);
+
+ begin
+ if not Is_Tag_Indeterminate (Original_Node (Expr)) then
+ return False;
+ end if;
+
+ Next (Expr);
+
+ if Present (Expr)
+ and then not Is_Tag_Indeterminate (Original_Node (Expr))
+ then
+ return False;
+ end if;
+
+ return True;
+ end;
+
+ -- A case-expression is tag-indeterminate if all of the dependent
+ -- expressions are tag-indeterminate (RM 4.5.7 (17/3)).
+
+ elsif Nkind (Orig_Node) = N_Case_Expression then
+ declare
+ Alt : Node_Id := First (Alternatives (Orig_Node));
+ Expr : Node_Id;
+
+ begin
+ while Present (Alt) loop
+ Expr := Expression (Alt);
+
+ if not Is_Tag_Indeterminate (Original_Node (Expr)) then
+ return False;
+ end if;
+
+ Next (Alt);
+ end loop;
+
+ return True;
+ end;
+
else
return False;
end if;
elsif Nkind (Actual) = N_Explicit_Dereference
and then Nkind (Original_Node (Prefix (Actual))) = N_Function_Call
then
+ pragma Assert (Is_Expanded_Dispatching_Call (Actual));
return;
-- When expansion is suppressed, an unexpanded call to 'Input can occur,
-- Has_Secondary_Private_View set in generic units
-- "plus fields for expression"
- -- Paren_Count number of parentheses levels
- -- Etype type of the expression
- -- Is_Overloaded >1 type interpretation exists
- -- Is_Static_Expression set for static expression
- -- Raises_Constraint_Error evaluation raises CE
- -- Must_Not_Freeze set if must not freeze
- -- Do_Range_Check set if a range check needed
- -- Has_Dynamic_Length_Check set if length check inserted
- -- Assignment_OK set if modification is OK
- -- Is_Controlling_Actual set for controlling argument
+ -- Paren_Count number of parentheses levels
+ -- Etype type of the expression
+ -- Is_Overloaded >1 type interpretation exists
+ -- Is_Static_Expression set for static expression
+ -- Raises_Constraint_Error evaluation raises CE
+ -- Must_Not_Freeze set if must not freeze
+ -- Do_Range_Check set if a range check needed
+ -- Has_Dynamic_Length_Check set if length check inserted
+ -- Assignment_OK set if modification is OK
+ -- Is_Controlling_Actual set for controlling argument
+ -- Is_Expanded_Dispatching_Call set for expanded dispatching calls
-- Note: see under (EXPRESSION) for further details on the use of
-- the Paren_Count field to record the number of parentheses levels.
-- actuals to support a build-in-place style of call have been added to
-- the call.
+ -- Is_Expanded_Dispatching_Call
+ -- This flag is set in N_Block_Statement, and expression nodes to
+ -- indicate that it is an expanded dispatching call.
+
-- Is_Expanded_Prefixed_Call
-- This flag is set in N_Function_Call and N_Procedure_Call_Statement
-- nodes to indicate that it is an expanded prefixed call.
-- statement applies to. Finally, if Analyze_Continue_Statement detects
-- an error, this field is set to Empty.
+ -- Tag_Propagated
+ -- This flag is set in N_Identifier, N_Explicit_Dereference, and N_Type_
+ -- Conversion nodes that are the LHS of an assignment statement. Used to
+ -- remember that the RHS of the assignment has tag indeterminate function
+ -- calls and the tag has been propagated to the calls (as part of the
+ -- bottom-up analysis of the RHS of the assignment statement).
+
-- Target_Type
-- Used in an N_Validate_Unchecked_Conversion node to point to the target
-- type entity for the unchecked conversion instantiation which gigi must
-- Has_Private_View (set in generic units)
-- Has_Secondary_Private_View (set in generic units)
-- Redundant_Use
+ -- Tag_Propagated
-- Atomic_Sync_Required
-- plus fields for expression
-- Prefix
-- Actual_Designated_Subtype
-- Has_Dereference_Action
+ -- Tag_Propagated
-- Atomic_Sync_Required
-- plus fields for expression
-- Conversion_OK
-- Do_Overflow_Check
-- Rounded_Result
+ -- Tag_Propagated
-- plus fields for expression
-- Note: if a range check is required, then the Do_Range_Check flag
-- Has_Created_Identifier
-- Is_Abort_Block
-- Is_Asynchronous_Call_Block
+ -- Is_Expanded_Dispatching_Call
-- Is_Initialization_Block
-- Is_Task_Allocation_Block
-- Is_Task_Master
projects / thirdparty / gcc.git / commitdiff
