From d79e7af5ff74c714b15d0cd123752cc4714e4dc6 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 16 Nov 2020 18:10:25 +0100 Subject: [PATCH] [Ada] Transform_Function_Array issues gcc/ada/ * exp_ch6.adb (Build_Procedure_Body_Form): Adjust, the declaration of the procedure form is now insert before the original function body rather than after. (Expand_N_Subprogram_Declaration): Deal with private types whose full views are arrays. * exp_unst.adb (Unnest_Subprogram): Deal with private types. (Needs_Fat_Pointer): Code cleanup. * freeze.adb (Freeze_Subprogram): Ditto. * exp_util.adb (Build_Procedure_Form): Insert the procedure form decl before and not after. * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Build missing spec when needed for Transform_Function_Array. * sem_util.adb (Get_Fullest_View): Deal with null entity. --- gcc/ada/exp_ch6.adb | 12 +++++++----- gcc/ada/exp_unst.adb | 21 ++++++++++---------- gcc/ada/exp_util.adb | 10 ++++++---- gcc/ada/freeze.adb | 6 ++++-- gcc/ada/sem_ch6.adb | 46 +++++++++++++++++++++++++++++++++----------- gcc/ada/sem_util.adb | 6 ++++++ 6 files changed, 69 insertions(+), 32 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 955049f4210..0a5fbccec82 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -883,9 +883,8 @@ package body Exp_Ch6 is is Loc : constant Source_Ptr := Sloc (Func_Body); - Proc_Decl : constant Node_Id := - Next (Unit_Declaration_Node (Func_Id)); - -- It is assumed that the next node following the declaration of the + Proc_Decl : constant Node_Id := Prev (Unit_Declaration_Node (Func_Id)); + -- It is assumed that the node before the declaration of the -- corresponding subprogram spec is the declaration of the procedure -- form. @@ -6571,6 +6570,7 @@ package body Exp_Ch6 is Prot_Bod : Node_Id; Prot_Decl : Node_Id; Prot_Id : Entity_Id; + Typ : Entity_Id; begin -- Deal with case of protected subprogram. Do not generate protected @@ -6645,10 +6645,12 @@ package body Exp_Ch6 is -- are not needed by the C generator (and this also produces cleaner -- output). + Typ := Get_Fullest_View (Etype (Subp)); + if Transform_Function_Array and then Nkind (Specification (N)) = N_Function_Specification - and then Is_Array_Type (Etype (Subp)) - and then Is_Constrained (Etype (Subp)) + and then Is_Array_Type (Typ) + and then Is_Constrained (Typ) and then not Is_Unchecked_Conversion_Instance (Subp) then Build_Procedure_Form (N); diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index e0f2bd1c6c0..ee2cf8113dc 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -251,13 +251,8 @@ package body Exp_Unst is ----------------------- function Needs_Fat_Pointer (E : Entity_Id) return Boolean is - Typ : Entity_Id := Etype (E); - + Typ : constant Entity_Id := Get_Fullest_View (Etype (E)); begin - if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then - Typ := Full_View (Typ); - end if; - return Is_Array_Type (Typ) and then not Is_Constrained (Typ); end Needs_Fat_Pointer; @@ -898,6 +893,8 @@ package body Exp_Unst is DT : Boolean := False; Formal : Node_Id; Subp : Entity_Id; + F_Type : Entity_Id; + A_Type : Entity_Id; begin if Nkind (Name (N)) = N_Explicit_Dereference then @@ -908,12 +905,16 @@ package body Exp_Unst is Actual := First_Actual (N); Formal := First_Formal_With_Extras (Subp); + while Present (Actual) loop - if Is_Array_Type (Etype (Formal)) - and then not Is_Constrained (Etype (Formal)) - and then Is_Constrained (Etype (Actual)) + F_Type := Get_Fullest_View (Etype (Formal)); + A_Type := Get_Fullest_View (Etype (Actual)); + + if Is_Array_Type (F_Type) + and then not Is_Constrained (F_Type) + and then Is_Constrained (A_Type) then - Check_Static_Type (Etype (Actual), Empty, DT); + Check_Static_Type (A_Type, Empty, DT); end if; Next_Actual (Actual); diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 21098b7c057..bcfedfb32bd 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -3994,9 +3994,11 @@ package body Exp_Util is Out_Present => True, Parameter_Type => New_Occurrence_Of (Etype (Subp), Loc))); - -- The new procedure declaration is inserted immediately after the - -- function declaration. The processing in Build_Procedure_Body_Form - -- relies on this order. + -- The new procedure declaration is inserted before the function + -- declaration. The processing in Build_Procedure_Body_Form relies on + -- this order. Note that we insert before because in the case of a + -- function body with no separate spec, we do not want to insert the + -- new spec after the body which will later get rewritten. Proc_Decl := Make_Subprogram_Declaration (Loc, @@ -4006,7 +4008,7 @@ package body Exp_Util is Make_Defining_Identifier (Loc, Chars (Subp)), Parameter_Specifications => Proc_Formals)); - Insert_After_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl); + Insert_Before_And_Analyze (Unit_Declaration_Node (Subp), Proc_Decl); -- Entity of procedure must remain invisible so that it does not -- overload subsequent references to the original function. diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 098b117cf84..b877b441de8 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -9225,10 +9225,12 @@ package body Freeze is Check_Overriding_Indicator (E, Empty, Is_Primitive (E)); end if; + Retype := Get_Fullest_View (Etype (E)); + if Transform_Function_Array and then Nkind (Parent (E)) = N_Function_Specification - and then Is_Array_Type (Etype (E)) - and then Is_Constrained (Etype (E)) + and then Is_Array_Type (Retype) + and then Is_Constrained (Retype) and then not Is_Unchecked_Conversion_Instance (E) and then not Rewritten_For_C (E) then diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 35e13a5750a..9aff0f59193 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -4401,22 +4401,46 @@ package body Sem_Ch6 is if Expander_Active and then Transform_Function_Array - and then Present (Spec_Id) - and then Ekind (Spec_Id) = E_Function and then Nkind (N) /= N_Subprogram_Body_Stub - and then Rewritten_For_C (Spec_Id) then - Set_Has_Completion (Spec_Id); + declare + S : constant Entity_Id := + (if Present (Spec_Id) + then Spec_Id + else Defining_Unit_Name (Specification (N))); + Proc_Body : Node_Id; - Rewrite (N, Build_Procedure_Body_Form (Spec_Id, N)); - Analyze (N); + begin + if Ekind (S) = E_Function and then Rewritten_For_C (S) then + Set_Has_Completion (S); + Proc_Body := Build_Procedure_Body_Form (S, N); - -- The entity for the created procedure must remain invisible, so it - -- does not participate in resolution of subsequent references to the - -- function. + if Present (Spec_Id) then + Rewrite (N, Proc_Body); + Analyze (N); - Set_Is_Immediately_Visible (Corresponding_Spec (N), False); - goto Leave; + -- The entity for the created procedure must remain + -- invisible, so it does not participate in resolution of + -- subsequent references to the function. + + Set_Is_Immediately_Visible (Corresponding_Spec (N), False); + + -- If we do not have a separate spec for N, build one and + -- insert the new body right after. + + else + Rewrite (N, + Make_Subprogram_Declaration (Loc, + Specification => Relocate_Node (Specification (N)))); + Analyze (N); + Insert_After_And_Analyze (N, Proc_Body); + Set_Is_Immediately_Visible + (Corresponding_Spec (Proc_Body), False); + end if; + + goto Leave; + end if; + end; end if; -- If a separate spec is present, then deal with freezing issues diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 063860af48c..c695cbc5266 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -10589,6 +10589,12 @@ package body Sem_Util is function Get_Fullest_View (E : Entity_Id; Include_PAT : Boolean := True) return Entity_Id is begin + -- Prevent cascaded errors + + if No (E) then + return E; + end if; + -- Strictly speaking, the recursion below isn't necessary, but -- it's both simplest and safest. -- 2.30.2