+2018-04-04 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * exp_cg.adb: Remove with and use clause for Exp_Disp.
+ * exp_ch9.adb: Remove with and use clause for Exp_Disp.
+ * exp_disp.adb (Is_Predefined_Dispatching_Operation): Moved to Sem_Util.
+ (Is_Predefined_Interface_Primitive): Moved to Sem_Util.
+ (Is_Predefined_Internal_Operation): Moved to Sem_Util.
+ * exp_disp.ads (Is_Predefined_Dispatching_Operation): Moved to Sem_Util.
+ (Is_Predefined_Interface_Primitive): Moved to Sem_Util.
+ (Is_Predefined_Internal_Operation): Moved to Sem_Util.
+ * exp_dist.adb: Remove with and use clause for Exp_Disp.
+ * freeze.adb: Remove with and use clause for Exp_Disp.
+ * sem_cat.adb: Remove with and use clause for Exp_Disp.
+ * sem_ch6.adb: Remove with and use clause for Exp_Disp.
+ * sem_ch12.adb: Remove with and use clause for Exp_Disp.
+ * sem_elab.adb (Check_Overriding_Primitive): Do not process predefined
+ primitives.
+ * sem_util.adb: Remove with and use clause for Exp_Disp.
+ (Is_Predefined_Dispatching_Operation): Moved from Exp_Disp.
+ (Is_Predefined_Interface_Primitive): Moved from Exp_Disp.
+ (Is_Predefined_Internal_Operation): Moved from Exp_Disp.
+ * sem_util.ads (Is_Predefined_Dispatching_Operation): Moved from
+ Exp_Disp.
+ (Is_Predefined_Interface_Primitive): Moved from Exp_Disp.
+ (Is_Predefined_Internal_Operation): Moved from Exp_Disp.
+
2018-04-04 Ed Schonberg <schonberg@adacore.com>
* sem_res.adb (Valid_Conversion): Improve error message on an illegal
with Atree; use Atree;
with Einfo; use Einfo;
with Elists; use Elists;
-with Exp_Disp; use Exp_Disp;
with Exp_Dbug; use Exp_Dbug;
with Exp_Tss; use Exp_Tss;
with Lib; use Lib;
with Exp_Ch6; use Exp_Ch6;
with Exp_Ch11; use Exp_Ch11;
with Exp_Dbug; use Exp_Dbug;
-with Exp_Disp; use Exp_Disp;
with Exp_Sel; use Exp_Sel;
with Exp_Smem; use Exp_Smem;
with Exp_Tss; use Exp_Tss;
and then Is_Dispatch_Table_Entity (Etype (Name (N)));
end Is_Expanded_Dispatching_Call;
- -----------------------------------------
- -- Is_Predefined_Dispatching_Operation --
- -----------------------------------------
-
- function Is_Predefined_Dispatching_Operation
- (E : Entity_Id) return Boolean
- is
- TSS_Name : TSS_Name_Type;
-
- begin
- if not Is_Dispatching_Operation (E) then
- return False;
- end if;
-
- Get_Name_String (Chars (E));
-
- -- Most predefined primitives have internally generated names. Equality
- -- must be treated differently; the predefined operation is recognized
- -- as a homogeneous binary operator that returns Boolean.
-
- if Name_Len > TSS_Name_Type'Last then
- TSS_Name := TSS_Name_Type (Name_Buffer (Name_Len - TSS_Name'Length + 1
- .. Name_Len));
- if Chars (E) = Name_uSize
- or else TSS_Name = TSS_Stream_Read
- or else TSS_Name = TSS_Stream_Write
- or else TSS_Name = TSS_Stream_Input
- or else TSS_Name = TSS_Stream_Output
- or else
- (Chars (E) = Name_Op_Eq
- and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
- or else Chars (E) = Name_uAssign
- or else TSS_Name = TSS_Deep_Adjust
- or else TSS_Name = TSS_Deep_Finalize
- or else Is_Predefined_Interface_Primitive (E)
- then
- return True;
- end if;
- end if;
-
- return False;
- end Is_Predefined_Dispatching_Operation;
-
- ---------------------------------------
- -- Is_Predefined_Internal_Operation --
- ---------------------------------------
-
- function Is_Predefined_Internal_Operation
- (E : Entity_Id) return Boolean
- is
- TSS_Name : TSS_Name_Type;
-
- begin
- if not Is_Dispatching_Operation (E) then
- return False;
- end if;
-
- Get_Name_String (Chars (E));
-
- -- Most predefined primitives have internally generated names. Equality
- -- must be treated differently; the predefined operation is recognized
- -- as a homogeneous binary operator that returns Boolean.
-
- if Name_Len > TSS_Name_Type'Last then
- TSS_Name :=
- TSS_Name_Type
- (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
-
- if Nam_In (Chars (E), Name_uSize, Name_uAssign)
- or else
- (Chars (E) = Name_Op_Eq
- and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
- or else TSS_Name = TSS_Deep_Adjust
- or else TSS_Name = TSS_Deep_Finalize
- or else Is_Predefined_Interface_Primitive (E)
- then
- return True;
- end if;
- end if;
-
- return False;
- end Is_Predefined_Internal_Operation;
-
-------------------------------------
-- Is_Predefined_Dispatching_Alias --
-------------------------------------
and then Is_Predefined_Dispatching_Operation (Ultimate_Alias (Prim));
end Is_Predefined_Dispatching_Alias;
- ---------------------------------------
- -- Is_Predefined_Interface_Primitive --
- ---------------------------------------
-
- function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
- begin
- -- In VM targets we don't restrict the functionality of this test to
- -- compiling in Ada 2005 mode since in VM targets any tagged type has
- -- these primitives.
-
- return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
- and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
- Name_uDisp_Conditional_Select,
- Name_uDisp_Get_Prim_Op_Kind,
- Name_uDisp_Get_Task_Id,
- Name_uDisp_Requeue,
- Name_uDisp_Timed_Select);
- end Is_Predefined_Interface_Primitive;
-
----------------------------------------
-- Make_Disp_Asynchronous_Select_Body --
----------------------------------------
function Is_Expanded_Dispatching_Call (N : Node_Id) return Boolean;
-- Returns true if N is the expanded code of a dispatching call
- function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
- -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
-
- function Is_Predefined_Internal_Operation (E : Entity_Id) return Boolean;
- -- Similar to the previous one, but excludes stream operations, because
- -- these may be overridden, and need extra formals, like user-defined
- -- operations.
-
- function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean;
- -- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives
- -- required to implement interfaces.
-
function Make_DT (Typ : Entity_Id; N : Node_Id := Empty) return List_Id;
-- Expand the declarations for the Dispatch Table. The node N is the
-- declaration that forces the generation of the table. It is used to place
with Einfo; use Einfo;
with Elists; use Elists;
with Exp_Atag; use Exp_Atag;
-with Exp_Disp; use Exp_Disp;
with Exp_Strm; use Exp_Strm;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Errout; use Errout;
with Exp_Ch3; use Exp_Ch3;
with Exp_Ch7; use Exp_Ch7;
-with Exp_Disp; use Exp_Disp;
with Exp_Pakd; use Exp_Pakd;
with Exp_Util; use Exp_Util;
with Exp_Tss; use Exp_Tss;
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
-with Exp_Disp; use Exp_Disp;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Elists; use Elists;
with Errout; use Errout;
with Expander; use Expander;
-with Exp_Disp; use Exp_Disp;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
with Freeze; use Freeze;
with Exp_Ch7; use Exp_Ch7;
with Exp_Ch9; use Exp_Ch9;
with Exp_Dbug; use Exp_Dbug;
-with Exp_Disp; use Exp_Disp;
with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
Region : Node_Id;
begin
+ -- Nothing to do for predefined primitives because they are artifacts
+ -- of tagged type expansion and cannot override source primitives.
+
+ if Is_Predefined_Dispatching_Operation (Prim) then
+ return;
+ end if;
+
Body_Id := Corresponding_Body (Prim_Decl);
-- Nothing to do when the primitive does not have a corresponding
with Errout; use Errout;
with Erroutc; use Erroutc;
with Exp_Ch11; use Exp_Ch11;
-with Exp_Disp; use Exp_Disp;
with Exp_Util; use Exp_Util;
with Fname; use Fname;
with Freeze; use Freeze;
end if;
end Is_Potentially_Unevaluated;
+ -----------------------------------------
+ -- Is_Predefined_Dispatching_Operation --
+ -----------------------------------------
+
+ function Is_Predefined_Dispatching_Operation
+ (E : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ if not Is_Dispatching_Operation (E) then
+ return False;
+ end if;
+
+ Get_Name_String (Chars (E));
+
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Nam_In (Chars (E), Name_uAssign, Name_uSize)
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else TSS_Name = TSS_Stream_Input
+ or else TSS_Name = TSS_Stream_Output
+ or else TSS_Name = TSS_Stream_Read
+ or else TSS_Name = TSS_Stream_Write
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Dispatching_Operation;
+
+ ---------------------------------------
+ -- Is_Predefined_Interface_Primitive --
+ ---------------------------------------
+
+ function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean is
+ begin
+ -- In VM targets we don't restrict the functionality of this test to
+ -- compiling in Ada 2005 mode since in VM targets any tagged type has
+ -- these primitives.
+
+ return (Ada_Version >= Ada_2005 or else not Tagged_Type_Expansion)
+ and then Nam_In (Chars (E), Name_uDisp_Asynchronous_Select,
+ Name_uDisp_Conditional_Select,
+ Name_uDisp_Get_Prim_Op_Kind,
+ Name_uDisp_Get_Task_Id,
+ Name_uDisp_Requeue,
+ Name_uDisp_Timed_Select);
+ end Is_Predefined_Interface_Primitive;
+
+ ---------------------------------------
+ -- Is_Predefined_Internal_Operation --
+ ---------------------------------------
+
+ function Is_Predefined_Internal_Operation
+ (E : Entity_Id) return Boolean
+ is
+ TSS_Name : TSS_Name_Type;
+
+ begin
+ if not Is_Dispatching_Operation (E) then
+ return False;
+ end if;
+
+ Get_Name_String (Chars (E));
+
+ -- Most predefined primitives have internally generated names. Equality
+ -- must be treated differently; the predefined operation is recognized
+ -- as a homogeneous binary operator that returns Boolean.
+
+ if Name_Len > TSS_Name_Type'Last then
+ TSS_Name :=
+ TSS_Name_Type
+ (Name_Buffer (Name_Len - TSS_Name'Length + 1 .. Name_Len));
+
+ if Nam_In (Chars (E), Name_uSize, Name_uAssign)
+ or else
+ (Chars (E) = Name_Op_Eq
+ and then Etype (First_Formal (E)) = Etype (Last_Formal (E)))
+ or else TSS_Name = TSS_Deep_Adjust
+ or else TSS_Name = TSS_Deep_Finalize
+ or else Is_Predefined_Interface_Primitive (E)
+ then
+ return True;
+ end if;
+ end if;
+
+ return False;
+ end Is_Predefined_Internal_Operation;
+
--------------------------------
-- Is_Preelaborable_Aggregate --
--------------------------------
-- persistent. A private type is potentially persistent if the full type
-- is potentially persistent.
+ function Is_Predefined_Dispatching_Operation (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-251): Determines if E is a predefined primitive operation
+
+ function Is_Predefined_Interface_Primitive (E : Entity_Id) return Boolean;
+ -- Ada 2005 (AI-345): Returns True if E is one of the predefined primitives
+ -- required to implement interfaces.
+
+ function Is_Predefined_Internal_Operation (E : Entity_Id) return Boolean;
+ -- Similar to the previous one, but excludes stream operations, because
+ -- these may be overridden, and need extra formals, like user-defined
+ -- operations.
+
function Is_Preelaborable_Aggregate (Aggr : Node_Id) return Boolean;
-- Determine whether aggregate Aggr violates the restrictions of
-- preelaborable constructs as defined in ARM 10.2.1(5-9).
projects / gcc.git / commitdiff