Rewrite (Prefix (N),
Convert_To (Btyp_DDT,
New_Copy_Tree (Prefix (N))));
+ Flag_Interface_Pointer_Displacement (Prefix (N));
Analyze_And_Resolve (Prefix (N), Btyp_DDT);
end if;
Rewrite (N,
Convert_To (Typ,
New_Copy_Tree (Prefix (Ref_Object))));
+ Flag_Interface_Pointer_Displacement (N);
+
Analyze_And_Resolve (N, Typ);
end if;
end;
Designated_Type (Etype (Parent (N)));
begin
Rewrite (Pref, Convert_To (Iface_Typ, Relocate_Node (Pref)));
+ Flag_Interface_Pointer_Displacement (Pref);
Analyze_And_Resolve (Pref, Iface_Typ);
return;
end;
-- the secondary dispatch table.
Rewrite (N, Convert_To (Dtyp, Relocate_Node (N)));
+ Flag_Interface_Pointer_Displacement (N);
Analyze_And_Resolve (N, Dtyp);
-- 3) The 'access to the secondary dispatch table will be used
if Is_Interface (R_Type) then
Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
+ Flag_Interface_Pointer_Displacement (Exp);
end if;
Analyze_And_Resolve (Exp, R_Type);
if Is_Interface (R_Type) then
Rewrite (Exp, Convert_To (R_Type, Relocate_Node (Exp)));
+ Flag_Interface_Pointer_Displacement (Exp);
end if;
Analyze_And_Resolve (Exp, R_Type);
and then Utyp /= Underlying_Type (Exp_Typ)
then
Rewrite (Exp, Convert_To (Utyp, Relocate_Node (Exp)));
+ Flag_Interface_Pointer_Displacement (Exp);
Analyze_And_Resolve (Exp);
end if;
Rewrite
(Ref_Func_Call,
OK_Convert_To (Acc_Type, Ref_Func_Call));
+ Flag_Interface_Pointer_Displacement (Ref_Func_Call);
-- If the types are incompatible, we need an unchecked conversion. Note
-- that the full types will be compatible, but the types not visibly
Rewrite (Allocator,
Convert_To (Etype (Allocator),
New_Occurrence_Of (Tmp_Id, Loc)));
+ Flag_Interface_Pointer_Displacement (Allocator);
end Make_Build_In_Place_Iface_Call_In_Allocator;
---------------------------------------------------------
if Is_Interface (Designated_Type (Acc_Type)) then
Rewrite (Allocator, Convert_To (Acc_Type, Relocate_Node (Allocator)));
+ Flag_Interface_Pointer_Displacement (Allocator);
end if;
Analyze_And_Resolve (Allocator, Acc_Type);
end if;
Conversion := Convert_To (Formal_Typ, Relocate_Node (Actual));
+ Flag_Interface_Pointer_Displacement (Conversion);
Rewrite (Actual, Conversion);
Analyze_And_Resolve (Actual, Formal_Typ);
end if;
Conversion := Convert_To (Formal_Typ, Actual_Dup);
Rewrite (Actual, Conversion);
+ Flag_Interface_Pointer_Displacement (Actual);
+
Analyze_And_Resolve (Actual, Formal_Typ);
end if;
end if;
Rewrite (N, Convert_To (Result_Typ, Cnstr_Call));
+ if Is_Interface (Result_Typ) then
+ Flag_Interface_Pointer_Displacement (N);
+ end if;
+
-- Do not generate a run-time check on the built object if tag
-- checks are suppressed for the result type or tagged type expansion
-- is disabled or if CodePeer_Mode.
end if;
end Find_Hook_Context;
+ -----------------------------------------
+ -- Flag_Interface_Pointer_Displacement --
+ -----------------------------------------
+
+ procedure Flag_Interface_Pointer_Displacement (N : Node_Id) is
+ begin
+ if Nkind (N) = N_Type_Conversion then
+ Set_Is_Interface_Pointer_Displacement (N);
+ end if;
+ end Flag_Interface_Pointer_Displacement;
+
------------------------------
-- Following_Address_Clause --
------------------------------
-- be evaluated, for example if N is the right operand of a short circuit
-- operator.
+ procedure Flag_Interface_Pointer_Displacement (N : Node_Id);
+ -- If N is an N_Type_Conversion node then flag N to indicate that this
+ -- type conversion was internally added to force the displacement of the
+ -- pointer to the object (pointer named "this" in the C++ terminology)
+ -- from a dispatch table to another dispatch table.
+
function Following_Address_Clause (D : Node_Id) return Node_Id;
-- D is the node for an object declaration. This function searches the
-- current declarative part to look for an address clause for the object
pragma Inline (Duplicate_Subexpr);
pragma Inline (Find_Controlled_Prim_Op);
pragma Inline (Find_Prim_Op);
+ pragma Inline (Flag_Interface_Pointer_Displacement);
pragma Inline (Force_Evaluation);
pragma Inline (Get_Mapped_Entity);
pragma Inline (Is_Library_Level_Tagged_Type);
Is_Implicit_With,
Is_In_Discriminant_Check,
Is_Initialization_Block,
+ Is_Interface_Pointer_Displacement,
Is_Interpolated_String_Literal,
Is_Known_Guaranteed_ABE,
Is_Machine_Number,
Sm (Do_Length_Check, Flag),
Sm (Do_Overflow_Check, Flag),
Sm (Float_Truncate, Flag),
+ Sm (Is_Interface_Pointer_Displacement, Flag),
Sm (Tag_Propagated, Flag),
Sm (Rounded_Result, Flag)));
return "Is_Elaboration_Warnings_OK_Node";
when Is_IEEE_Extended_Precision =>
return "Is_IEEE_Extended_Precision";
+ when Is_Interface_Pointer_Displacement =>
+ return "Is_Interface_Pointer_Displacement";
when Is_Known_Guaranteed_ABE =>
return "Is_Known_Guaranteed_ABE";
when Is_RACW_Stub_Type =>
Designated_Type (Etype (Expr)))
then
Rewrite (Expr, Convert_To (R_Type, Relocate_Node (Expr)));
+ Flag_Interface_Pointer_Displacement (Expr);
+
Analyze (Expr);
end if;
Subtype_Mark =>
New_Occurrence_Of (Etype (Control), Sloc (Call_Node)),
Expression => Relocate_Node (Call_Node)));
+ Flag_Interface_Pointer_Displacement (Call_Node);
Set_Etype (Call_Node, Etype (Control));
Set_Analyzed (Call_Node);
and then Is_Interface (DDT)
then
Rewrite (A, Convert_To (Etype (F), Relocate_Node (A)));
+ Flag_Interface_Pointer_Displacement (A);
+
Analyze_And_Resolve (A, Etype (F),
Suppress => Access_Check);
end if;
-- reference the corresponding dispatch table.
elsif not Comes_From_Source (N)
+ and then Nkind (N) = N_Type_Conversion
and then Is_Access_Type (Target_Type)
and then Is_Interface (Designated_Type (Target_Type))
+ and then Is_Interface_Pointer_Displacement (N)
then
return True;
- -- Ada 2005 (AI-251): Anonymous access types where target references an
- -- interface type.
-
- elsif Is_Access_Type (Opnd_Type)
- and then Ekind (Target_Type) in
- E_General_Access_Type | E_Anonymous_Access_Type
- and then Is_Interface (Directly_Designated_Type (Target_Type))
- then
- -- Check the static accessibility rule of 4.6(17). Note that the
- -- check is not enforced when within an instance body, since the
- -- RM requires such cases to be caught at run time.
-
- -- If the operand is a rewriting of an allocator no check is needed
- -- because there are no accessibility issues.
-
- if Nkind (Original_Node (N)) = N_Allocator then
- null;
-
- elsif Ekind (Target_Type) /= E_Anonymous_Access_Type then
- if Type_Access_Level (Opnd_Type) >
- Deepest_Type_Access_Level (Target_Type)
- then
- -- In an instance, this is a run-time check, but one we know
- -- will fail, so generate an appropriate warning. The raise
- -- will be generated by Expand_N_Type_Conversion.
-
- if In_Instance_Body then
- Error_Msg_Warn := SPARK_Mode /= On;
- Report_Error_N
- ("cannot convert local pointer to non-local access type<<",
- Operand, Report_Errs);
- Report_Error_N ("\Program_Error [<<", Operand, Report_Errs);
-
- else
- Report_Error_N
- ("cannot convert local pointer to non-local access type",
- Operand, Report_Errs);
- return False;
- end if;
-
- -- Special accessibility checks are needed in the case of access
- -- discriminants declared for a limited type.
-
- elsif Ekind (Opnd_Type) = E_Anonymous_Access_Type
- and then not Is_Local_Anonymous_Access (Opnd_Type)
- then
- -- When the operand is a selected access discriminant the check
- -- needs to be made against the level of the object denoted by
- -- the prefix of the selected name (Accessibility_Level handles
- -- checking the prefix of the operand for this case).
-
- if Nkind (Operand) = N_Selected_Component
- and then Static_Accessibility_Level
- (Operand, Zero_On_Dynamic_Level)
- > Deepest_Type_Access_Level (Target_Type)
- then
- -- In an instance, this is a run-time check, but one we know
- -- will fail, so generate an appropriate warning. The raise
- -- will be generated by Expand_N_Type_Conversion.
-
- if In_Instance_Body then
- Error_Msg_Warn := SPARK_Mode /= On;
- Report_Error_N
- ("cannot convert access discriminant to non-local "
- & "access type<<", Operand, Report_Errs);
- Report_Error_N
- ("\Program_Error [<<", Operand, Report_Errs);
-
- -- Real error if not in instance body
-
- else
- Report_Error_N
- ("cannot convert access discriminant to non-local "
- & "access type", Operand, Report_Errs);
- return False;
- end if;
- end if;
-
- -- The case of a reference to an access discriminant from
- -- within a limited type declaration (which will appear as
- -- a discriminal) is always illegal because the level of the
- -- discriminant is considered to be deeper than any (nameable)
- -- access type.
-
- if Is_Entity_Name (Operand)
- and then not Is_Local_Anonymous_Access (Opnd_Type)
- and then
- Ekind (Entity (Operand)) in E_In_Parameter | E_Constant
- and then Present (Discriminal_Link (Entity (Operand)))
- then
- Report_Error_N
- ("discriminant has deeper accessibility level than target",
- Operand, Report_Errs);
- return False;
- end if;
- end if;
- end if;
-
- return True;
-
-- General and anonymous access types
elsif Ekind (Target_Type) in
end;
-- Check the static accessibility rule of 4.6(17). Note that the
- -- check is not enforced when within an instance body, since the RM
- -- requires such cases to be caught at run time.
+ -- check is not enforced when within an instance body, since the
+ -- RM requires such cases to be caught at run time.
+
+ -- If the operand is a rewriting of an allocator no check is needed
+ -- because there are no accessibility issues.
+
+ if Nkind (Original_Node (N)) = N_Allocator then
+ null;
- if Ekind (Target_Type) /= E_Anonymous_Access_Type
+ elsif Ekind (Target_Type) /= E_Anonymous_Access_Type
or else Is_Local_Anonymous_Access (Target_Type)
or else Nkind (Associated_Node_For_Itype (Target_Type)) =
N_Object_Declaration
end if;
if Is_Concurrent_Record_Type (Target_Typ) then
- Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
+ if Is_Class_Wide_Type (Target_Typ) then
+ Target_Typ :=
+ Corresponding_Concurrent_Type (Root_Type (Target_Typ));
+ else
+ Target_Typ := Corresponding_Concurrent_Type (Target_Typ);
+ end if;
end if;
Target_Typ := Base_Type (Target_Typ);
-- composed of interpolated string elements from string literals found
-- in interpolated expressions.
+ -- Is_Interface_Pointer_Displacement
+ -- This flag is set in N_Type_Conversion nodes, and is used to indicate
+ -- that the type conversion was generated to displace the pointer to one
+ -- tagged object (pointer named "this" in the C++ terminology) from a
+ -- dispatch table to another dispatch table.
+
-- Is_Known_Guaranteed_ABE
-- Note: this flag is shared between the legacy ABE mechanism and the
-- default ABE mechanism.
-- Do_Overflow_Check
-- Rounded_Result
-- Tag_Propagated
+ -- Is_Interface_Pointer_Displacement
-- plus fields for expression
-- Note: if a range check is required, then the Do_Range_Check flag
projects / thirdparty / gcc.git / commitdiff
