From 7a500fd767dd9f7afff999dd1d9c8bbb6dbef268 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Mon, 21 May 2018 14:52:11 +0000 Subject: [PATCH] [Ada] Spurious error on early call region of tagged type This patch corrects the part of the access-before-elaboration mechanism which ensures that the freeze node of a tagged type is within the early call region of all its overriding bodies to ignore predefined primitives. ------------ -- Source -- ------------ -- pack.ads package Pack with SPARK_Mode is type Parent_Typ is tagged null record; procedure Prim (Obj : Parent_Typ); type Deriv_Typ is new Parent_Typ with private; overriding procedure Prim (Obj : Deriv_Typ); private type Deriv_Typ is new Parent_Typ with null record; end Pack; ----------------- -- Compilation -- ----------------- $ gcc -c pack.ads 2018-05-21 Hristian Kirtchev gcc/ada/ * 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. From-SVN: r260467 --- gcc/ada/ChangeLog | 26 +++++++++++ gcc/ada/exp_cg.adb | 1 - gcc/ada/exp_ch9.adb | 1 - gcc/ada/exp_disp.adb | 102 ------------------------------------------ gcc/ada/exp_disp.ads | 12 ----- gcc/ada/exp_dist.adb | 1 - gcc/ada/freeze.adb | 1 - gcc/ada/sem_cat.adb | 1 - gcc/ada/sem_ch12.adb | 1 - gcc/ada/sem_ch6.adb | 1 - gcc/ada/sem_elab.adb | 7 +++ gcc/ada/sem_util.adb | 104 ++++++++++++++++++++++++++++++++++++++++++- gcc/ada/sem_util.ads | 12 +++++ 13 files changed, 148 insertions(+), 122 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5cbb973ecd9..5f56158c1c2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2018-04-04 Hristian Kirtchev + + * 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 * sem_res.adb (Valid_Conversion): Improve error message on an illegal diff --git a/gcc/ada/exp_cg.adb b/gcc/ada/exp_cg.adb index 883b7a07201..00f029b10fd 100644 --- a/gcc/ada/exp_cg.adb +++ b/gcc/ada/exp_cg.adb @@ -26,7 +26,6 @@ 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; diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 9c2a1650611..981c0ee7e1f 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -31,7 +31,6 @@ with Exp_Ch3; use Exp_Ch3; 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; diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index bcf566a226e..c9181e59233 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -2177,89 +2177,6 @@ package body Exp_Disp is 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 -- ------------------------------------- @@ -2272,25 +2189,6 @@ package body Exp_Disp is 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 -- ---------------------------------------- diff --git a/gcc/ada/exp_disp.ads b/gcc/ada/exp_disp.ads index c519be90ea8..4a22d20f39c 100644 --- a/gcc/ada/exp_disp.ads +++ b/gcc/ada/exp_disp.ads @@ -258,18 +258,6 @@ package Exp_Disp is 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 diff --git a/gcc/ada/exp_dist.adb b/gcc/ada/exp_dist.adb index c354641b253..546b56f2e17 100644 --- a/gcc/ada/exp_dist.adb +++ b/gcc/ada/exp_dist.adb @@ -27,7 +27,6 @@ with Atree; use Atree; 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; diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 958f3e08c05..0df747b9118 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -33,7 +33,6 @@ with Elists; use Elists; 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; diff --git a/gcc/ada/sem_cat.adb b/gcc/ada/sem_cat.adb index 7485729c307..70ea9cf6169 100644 --- a/gcc/ada/sem_cat.adb +++ b/gcc/ada/sem_cat.adb @@ -28,7 +28,6 @@ with Debug; use Debug; 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; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 4af669443f0..8f7ba5cb01a 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -30,7 +30,6 @@ with Einfo; use Einfo; 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; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index c88721fa28c..dd0af492f8b 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -36,7 +36,6 @@ with Exp_Ch6; use Exp_Ch6; 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; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 69d46f4f857..4987f93b9a8 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -2525,6 +2525,13 @@ package body Sem_Elab is 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 diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 55554417a85..52fd14f3619 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -34,7 +34,6 @@ with Elists; use Elists; 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; @@ -16094,6 +16093,109 @@ package body Sem_Util is 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 -- -------------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index a9908516a9f..5007bb64487 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1842,6 +1842,18 @@ package Sem_Util is -- 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). -- 2.30.2