From 4d1429b2dd3fafdb24f9cd324cfd063b13b275d8 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 10 Oct 2014 16:45:27 +0200 Subject: [PATCH] [multiple changes] 2014-10-10 Robert Dewar * freeze.adb, gnat1drv.adb, sem_ch13.adb: Minor reformatting and code clean up. 2014-10-10 Hristian Kirtchev * sem_res.adb (Is_OK_Volatile_Context): Allow a volatile object reference to appear as the expression of a type conversion. From-SVN: r216091 --- gcc/ada/ChangeLog | 11 + gcc/ada/freeze.adb | 692 ++++++++++++++++++++++++++------------------------- gcc/ada/gnat1drv.adb | 7 +- gcc/ada/sem_ch13.adb | 6 +- gcc/ada/sem_res.adb | 12 + 5 files changed, 380 insertions(+), 348 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 50e654c..f43c709 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,14 @@ +2014-10-10 Robert Dewar + + * freeze.adb, gnat1drv.adb, sem_ch13.adb: Minor reformatting and + code clean up. + +2014-10-10 Hristian Kirtchev + + * sem_res.adb (Is_OK_Volatile_Context): Allow + a volatile object reference to appear as the expression of a + type conversion. + 2014-10-10 Ed Schonberg * sem_ch13.adb (Analyze_Aspect_Specifications, Library_Unit_Aspects): diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index bdc2ea1..3ae0f50 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1857,6 +1857,13 @@ package body Freeze is -- Create Freeze_Generic_Entity nodes for types declared in a generic -- package. Recurse on inner generic packages. + function Freeze_Profile (E : Entity_Id) return Boolean; + -- Freeze formals and return type of subprogram. + -- If some type in the profile is a limited view, freezing of the entity + -- will take place elsewhere, and the function returns False. + -- This routine will be modified if and when we can implement AI05-019 + -- efficiently. + procedure Freeze_Record_Type (Rec : Entity_Id); -- Freeze record type, including freezing component types, and freezing -- primitive operations if this is a tagged type. @@ -2681,6 +2688,341 @@ package body Freeze is return Flist; end Freeze_Generic_Entities; + -------------------- + -- Freeze_Profile -- + -------------------- + + function Freeze_Profile (E : Entity_Id) return Boolean is + F_Type : Entity_Id; + R_Type : Entity_Id; + Warn_Node : Node_Id; + + begin + -- Loop through formals + + Formal := First_Formal (E); + while Present (Formal) loop + F_Type := Etype (Formal); + + -- AI05-0151: incomplete types can appear in a profile. + -- By the time the entity is frozen, the full view must + -- be available, unless it is a limited view. + + if Is_Incomplete_Type (F_Type) + and then Present (Full_View (F_Type)) + and then not From_Limited_With (F_Type) + then + F_Type := Full_View (F_Type); + Set_Etype (Formal, F_Type); + end if; + + Freeze_And_Append (F_Type, N, Result); + + if Is_Private_Type (F_Type) + and then Is_Private_Type (Base_Type (F_Type)) + and then No (Full_View (Base_Type (F_Type))) + and then not Is_Generic_Type (F_Type) + and then not Is_Derived_Type (F_Type) + then + -- If the type of a formal is incomplete, subprogram + -- is being frozen prematurely. Within an instance + -- (but not within a wrapper package) this is an + -- artifact of our need to regard the end of an + -- instantiation as a freeze point. Otherwise it is + -- a definite error. + + if In_Instance then + Set_Is_Frozen (E, False); + Result := No_List; + return False; + + elsif not After_Last_Declaration + and then not Freezing_Library_Level_Tagged_Type + then + Error_Msg_Node_1 := F_Type; + Error_Msg + ("type& must be fully defined before this point", + Loc); + end if; + end if; + + -- Check suspicious parameter for C function. These tests + -- apply only to exported/imported subprograms. + + if Warn_On_Export_Import + and then Comes_From_Source (E) + and then (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + and then (Is_Imported (E) or else Is_Exported (E)) + and then Convention (E) /= Convention (Formal) + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (F_Type) + and then not Has_Warnings_Off (Formal) + then + -- Qualify mention of formals with subprogram name + + Error_Msg_Qual_Level := 1; + + -- Check suspicious use of fat C pointer + + if Is_Access_Type (F_Type) + and then Esize (F_Type) > Ttypes.System_Address_Size + then + Error_Msg_N + ("?x?type of & does not correspond to C pointer!", Formal); + + -- Check suspicious return of boolean + + elsif Root_Type (F_Type) = Standard_Boolean + and then Convention (F_Type) = Convention_Ada + and then not Has_Warnings_Off (F_Type) + and then not Has_Size_Clause (F_Type) + and then VM_Target = No_VM + then + Error_Msg_N ("& is an 8-bit Ada Boolean?x?", Formal); + Error_Msg_N ("\use appropriate corresponding type in C " + & "(e.g. char)?x?", Formal); + + -- Check suspicious tagged type + + elsif (Is_Tagged_Type (F_Type) + or else (Is_Access_Type (F_Type) + and then + Is_Tagged_Type + (Designated_Type (F_Type)))) + and then Convention (E) = Convention_C + then + Error_Msg_N ("?x?& involves a tagged type which does not " + & "correspond to any C type!", Formal); + + -- Check wrong convention subprogram pointer + + elsif Ekind (F_Type) = E_Access_Subprogram_Type + and then not Has_Foreign_Convention (F_Type) + then + Error_Msg_N ("?x?subprogram pointer & should " + & "have foreign convention!", Formal); + Error_Msg_Sloc := Sloc (F_Type); + Error_Msg_NE + ("\?x?add Convention pragma to declaration of &#", + Formal, F_Type); + end if; + + -- Turn off name qualification after message output + + Error_Msg_Qual_Level := 0; + end if; + + -- Check for unconstrained array in exported foreign + -- convention case. + + if Has_Foreign_Convention (E) + and then not Is_Imported (E) + and then Is_Array_Type (F_Type) + and then not Is_Constrained (F_Type) + and then Warn_On_Export_Import + + -- Exclude VM case, since both .NET and JVM can handle + -- unconstrained arrays without a problem. + + and then VM_Target = No_VM + then + Error_Msg_Qual_Level := 1; + + -- If this is an inherited operation, place the + -- warning on the derived type declaration, rather + -- than on the original subprogram. + + if Nkind (Original_Node (Parent (E))) = N_Full_Type_Declaration + then + Warn_Node := Parent (E); + + if Formal = First_Formal (E) then + Error_Msg_NE + ("??in inherited operation&", Warn_Node, E); + end if; + else + Warn_Node := Formal; + end if; + + Error_Msg_NE ("?x?type of argument& is unconstrained array", + Warn_Node, Formal); + Error_Msg_NE ("?x?foreign caller must pass bounds explicitly", + Warn_Node, Formal); + Error_Msg_Qual_Level := 0; + end if; + + if not From_Limited_With (F_Type) then + if Is_Access_Type (F_Type) then + F_Type := Designated_Type (F_Type); + end if; + + -- If the formal is an anonymous_access_to_subprogram + -- freeze the subprogram type as well, to prevent + -- scope anomalies in gigi, because there is no other + -- clear point at which it could be frozen. + + if Is_Itype (Etype (Formal)) + and then Ekind (F_Type) = E_Subprogram_Type + then + Freeze_And_Append (F_Type, N, Result); + end if; + end if; + + Next_Formal (Formal); + end loop; + + -- Case of function: similar checks on return type + + if Ekind (E) = E_Function then + + -- Check whether function is declared elsewhere. + + Late_Freezing := + Get_Source_Unit (E) /= Get_Source_Unit (N) + and then Returns_Limited_View (E) + and then not In_Open_Scopes (Scope (E)); + + -- Freeze return type + + R_Type := Etype (E); + + -- AI05-0151: the return type may have been incomplete + -- at the point of declaration. Replace it with the full + -- view, unless the current type is a limited view. In + -- that case the full view is in a different unit, and + -- gigi finds the non-limited view after the other unit + -- is elaborated. + + if Ekind (R_Type) = E_Incomplete_Type + and then Present (Full_View (R_Type)) + and then not From_Limited_With (R_Type) + then + R_Type := Full_View (R_Type); + Set_Etype (E, R_Type); + + -- If the return type is a limited view and the non- + -- limited view is still incomplete, the function has + -- to be frozen at a later time. + + elsif Ekind (R_Type) = E_Incomplete_Type + and then From_Limited_With (R_Type) + and then + Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type + then + Set_Is_Frozen (E, False); + Set_Returns_Limited_View (E); + return False; + end if; + + Freeze_And_Append (R_Type, N, Result); + + -- Check suspicious return type for C function + + if Warn_On_Export_Import + and then (Convention (E) = Convention_C + or else + Convention (E) = Convention_CPP) + and then (Is_Imported (E) or else Is_Exported (E)) + then + -- Check suspicious return of fat C pointer + + if Is_Access_Type (R_Type) + and then Esize (R_Type) > Ttypes.System_Address_Size + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + then + Error_Msg_N ("?x?return type of& does not " + & "correspond to C pointer!", E); + + -- Check suspicious return of boolean + + elsif Root_Type (R_Type) = Standard_Boolean + and then Convention (R_Type) = Convention_Ada + and then VM_Target = No_VM + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + and then not Has_Size_Clause (R_Type) + then + declare + N : constant Node_Id := + Result_Definition (Declaration_Node (E)); + begin + Error_Msg_NE + ("return type of & is an 8-bit Ada Boolean?x?", N, E); + Error_Msg_NE + ("\use appropriate corresponding type in C " + & "(e.g. char)?x?", N, E); + end; + + -- Check suspicious return tagged type + + elsif (Is_Tagged_Type (R_Type) + or else (Is_Access_Type (R_Type) + and then + Is_Tagged_Type + (Designated_Type (R_Type)))) + and then Convention (E) = Convention_C + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + then + Error_Msg_N ("?x?return type of & does not " + & "correspond to C type!", E); + + -- Check return of wrong convention subprogram pointer + + elsif Ekind (R_Type) = E_Access_Subprogram_Type + and then not Has_Foreign_Convention (R_Type) + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + then + Error_Msg_N ("?x?& should return a foreign " + & "convention subprogram pointer", E); + Error_Msg_Sloc := Sloc (R_Type); + Error_Msg_NE + ("\?x?add Convention pragma to declaration of& #", + E, R_Type); + end if; + end if; + + -- Give warning for suspicious return of a result of an + -- unconstrained array type in a foreign convention + -- function. + + if Has_Foreign_Convention (E) + + -- We are looking for a return of unconstrained array + + and then Is_Array_Type (R_Type) + and then not Is_Constrained (R_Type) + + -- Exclude imported routines, the warning does not + -- belong on the import, but rather on the routine + -- definition. + + and then not Is_Imported (E) + + -- Exclude VM case, since both .NET and JVM can handle + -- return of unconstrained arrays without a problem. + + and then VM_Target = No_VM + + -- Check that general warning is enabled, and that it + -- is not suppressed for this particular case. + + and then Warn_On_Export_Import + and then not Has_Warnings_Off (E) + and then not Has_Warnings_Off (R_Type) + then + Error_Msg_N ("?x?foreign convention function& should not " & + "return unconstrained array!", E); + end if; + end if; + + return True; + end Freeze_Profile; + ------------------------ -- Freeze_Record_Type -- ------------------------ @@ -4009,352 +4351,12 @@ package body Freeze is -- reference is not a freezing point of the profile. -- Other constructs that should not freeze ??? - if Ada_Version > Ada_2005 - and then Nkind (N) = N_Attribute_Reference - then - null; - - elsif not Is_Internal (E) then - declare - F_Type : Entity_Id; - R_Type : Entity_Id; - Warn_Node : Node_Id; - - begin - -- Loop through formals - - Formal := First_Formal (E); - while Present (Formal) loop - F_Type := Etype (Formal); - - -- AI05-0151: incomplete types can appear in a profile. - -- By the time the entity is frozen, the full view must - -- be available, unless it is a limited view. - - if Is_Incomplete_Type (F_Type) - and then Present (Full_View (F_Type)) - and then not From_Limited_With (F_Type) - then - F_Type := Full_View (F_Type); - Set_Etype (Formal, F_Type); - end if; - - Freeze_And_Append (F_Type, N, Result); - - if Is_Private_Type (F_Type) - and then Is_Private_Type (Base_Type (F_Type)) - and then No (Full_View (Base_Type (F_Type))) - and then not Is_Generic_Type (F_Type) - and then not Is_Derived_Type (F_Type) - then - -- If the type of a formal is incomplete, subprogram - -- is being frozen prematurely. Within an instance - -- (but not within a wrapper package) this is an - -- artifact of our need to regard the end of an - -- instantiation as a freeze point. Otherwise it is - -- a definite error. - - if In_Instance then - Set_Is_Frozen (E, False); - return No_List; - - elsif not After_Last_Declaration - and then not Freezing_Library_Level_Tagged_Type - then - Error_Msg_Node_1 := F_Type; - Error_Msg - ("type& must be fully defined before this point", - Loc); - end if; - end if; - - -- Check suspicious parameter for C function. These tests - -- apply only to exported/imported subprograms. - - if Warn_On_Export_Import - and then Comes_From_Source (E) - and then (Convention (E) = Convention_C - or else - Convention (E) = Convention_CPP) - and then (Is_Imported (E) or else Is_Exported (E)) - and then Convention (E) /= Convention (Formal) - and then not Has_Warnings_Off (E) - and then not Has_Warnings_Off (F_Type) - and then not Has_Warnings_Off (Formal) - then - -- Qualify mention of formals with subprogram name - - Error_Msg_Qual_Level := 1; - - -- Check suspicious use of fat C pointer - - if Is_Access_Type (F_Type) - and then Esize (F_Type) > Ttypes.System_Address_Size - then - Error_Msg_N - ("?x?type of & does not correspond to C pointer!", - Formal); - - -- Check suspicious return of boolean - - elsif Root_Type (F_Type) = Standard_Boolean - and then Convention (F_Type) = Convention_Ada - and then not Has_Warnings_Off (F_Type) - and then not Has_Size_Clause (F_Type) - and then VM_Target = No_VM - then - Error_Msg_N - ("& is an 8-bit Ada Boolean?x?", Formal); - Error_Msg_N - ("\use appropriate corresponding type in C " - & "(e.g. char)?x?", Formal); - - -- Check suspicious tagged type - - elsif (Is_Tagged_Type (F_Type) - or else (Is_Access_Type (F_Type) - and then - Is_Tagged_Type - (Designated_Type (F_Type)))) - and then Convention (E) = Convention_C - then - Error_Msg_N - ("?x?& involves a tagged type which does not " - & "correspond to any C type!", Formal); - - -- Check wrong convention subprogram pointer - - elsif Ekind (F_Type) = E_Access_Subprogram_Type - and then not Has_Foreign_Convention (F_Type) - then - Error_Msg_N - ("?x?subprogram pointer & should " - & "have foreign convention!", Formal); - Error_Msg_Sloc := Sloc (F_Type); - Error_Msg_NE - ("\?x?add Convention pragma to declaration of &#", - Formal, F_Type); - end if; - - -- Turn off name qualification after message output - - Error_Msg_Qual_Level := 0; - end if; + -- This processing doesn't apply to internal entities (see below) - -- Check for unconstrained array in exported foreign - -- convention case. - - if Has_Foreign_Convention (E) - and then not Is_Imported (E) - and then Is_Array_Type (F_Type) - and then not Is_Constrained (F_Type) - and then Warn_On_Export_Import - - -- Exclude VM case, since both .NET and JVM can handle - -- unconstrained arrays without a problem. - - and then VM_Target = No_VM - then - Error_Msg_Qual_Level := 1; - - -- If this is an inherited operation, place the - -- warning on the derived type declaration, rather - -- than on the original subprogram. - - if Nkind (Original_Node (Parent (E))) = - N_Full_Type_Declaration - then - Warn_Node := Parent (E); - - if Formal = First_Formal (E) then - Error_Msg_NE - ("??in inherited operation&", Warn_Node, E); - end if; - else - Warn_Node := Formal; - end if; - - Error_Msg_NE - ("?x?type of argument& is unconstrained array", - Warn_Node, Formal); - Error_Msg_NE - ("?x?foreign caller must pass bounds explicitly", - Warn_Node, Formal); - Error_Msg_Qual_Level := 0; - end if; - - if not From_Limited_With (F_Type) then - if Is_Access_Type (F_Type) then - F_Type := Designated_Type (F_Type); - end if; - - -- If the formal is an anonymous_access_to_subprogram - -- freeze the subprogram type as well, to prevent - -- scope anomalies in gigi, because there is no other - -- clear point at which it could be frozen. - - if Is_Itype (Etype (Formal)) - and then Ekind (F_Type) = E_Subprogram_Type - then - Freeze_And_Append (F_Type, N, Result); - end if; - end if; - - Next_Formal (Formal); - end loop; - - -- Case of function: similar checks on return type - - if Ekind (E) = E_Function then - - -- Check whether function is declared elsewhere. - - Late_Freezing := - Get_Source_Unit (E) /= Get_Source_Unit (N) - and then Returns_Limited_View (E) - and then not In_Open_Scopes (Scope (E)); - - -- Freeze return type - - R_Type := Etype (E); - - -- AI05-0151: the return type may have been incomplete - -- at the point of declaration. Replace it with the full - -- view, unless the current type is a limited view. In - -- that case the full view is in a different unit, and - -- gigi finds the non-limited view after the other unit - -- is elaborated. - - if Ekind (R_Type) = E_Incomplete_Type - and then Present (Full_View (R_Type)) - and then not From_Limited_With (R_Type) - then - R_Type := Full_View (R_Type); - Set_Etype (E, R_Type); - - -- If the return type is a limited view and the non- - -- limited view is still incomplete, the function has - -- to be frozen at a later time. - - elsif Ekind (R_Type) = E_Incomplete_Type - and then From_Limited_With (R_Type) - and then - Ekind (Non_Limited_View (R_Type)) = E_Incomplete_Type - then - Set_Is_Frozen (E, False); - Set_Returns_Limited_View (E); - return Result; - end if; - - Freeze_And_Append (R_Type, N, Result); - - -- Check suspicious return type for C function - - if Warn_On_Export_Import - and then (Convention (E) = Convention_C - or else - Convention (E) = Convention_CPP) - and then (Is_Imported (E) or else Is_Exported (E)) - then - -- Check suspicious return of fat C pointer - - if Is_Access_Type (R_Type) - and then Esize (R_Type) > Ttypes.System_Address_Size - and then not Has_Warnings_Off (E) - and then not Has_Warnings_Off (R_Type) - then - Error_Msg_N - ("?x?return type of& does not " - & "correspond to C pointer!", E); - - -- Check suspicious return of boolean - - elsif Root_Type (R_Type) = Standard_Boolean - and then Convention (R_Type) = Convention_Ada - and then VM_Target = No_VM - and then not Has_Warnings_Off (E) - and then not Has_Warnings_Off (R_Type) - and then not Has_Size_Clause (R_Type) - then - declare - N : constant Node_Id := - Result_Definition (Declaration_Node (E)); - begin - Error_Msg_NE - ("return type of & is an 8-bit Ada Boolean?x?", - N, E); - Error_Msg_NE - ("\use appropriate corresponding type in C " - & "(e.g. char)?x?", N, E); - end; - - -- Check suspicious return tagged type - - elsif (Is_Tagged_Type (R_Type) - or else (Is_Access_Type (R_Type) - and then - Is_Tagged_Type - (Designated_Type (R_Type)))) - and then Convention (E) = Convention_C - and then not Has_Warnings_Off (E) - and then not Has_Warnings_Off (R_Type) - then - Error_Msg_N - ("?x?return type of & does not " - & "correspond to C type!", E); - - -- Check return of wrong convention subprogram pointer - - elsif Ekind (R_Type) = E_Access_Subprogram_Type - and then not Has_Foreign_Convention (R_Type) - and then not Has_Warnings_Off (E) - and then not Has_Warnings_Off (R_Type) - then - Error_Msg_N - ("?x?& should return a foreign " - & "convention subprogram pointer", E); - Error_Msg_Sloc := Sloc (R_Type); - Error_Msg_NE - ("\?x?add Convention pragma to declaration of& #", - E, R_Type); - end if; - end if; - - -- Give warning for suspicious return of a result of an - -- unconstrained array type in a foreign convention - -- function. - - if Has_Foreign_Convention (E) - - -- We are looking for a return of unconstrained array - - and then Is_Array_Type (R_Type) - and then not Is_Constrained (R_Type) - - -- Exclude imported routines, the warning does not - -- belong on the import, but rather on the routine - -- definition. - - and then not Is_Imported (E) - - -- Exclude VM case, since both .NET and JVM can handle - -- return of unconstrained arrays without a problem. - - and then VM_Target = No_VM - - -- Check that general warning is enabled, and that it - -- is not suppressed for this particular case. - - and then Warn_On_Export_Import - and then not Has_Warnings_Off (E) - and then not Has_Warnings_Off (R_Type) - then - Error_Msg_N - ("?x?foreign convention function& should not " & - "return unconstrained array!", E); - end if; - end if; - end; + if not Is_Internal (E) then + if not Freeze_Profile (E) then + return Result; + end if; end if; -- Must freeze its parent first if it is a derived subprogram diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index 545d143..4cbb8cb 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -585,7 +585,12 @@ procedure Gnat1drv is -- Treat -gnatn as equivalent to -gnatN for non-GCC targets - if Inline_Active and then not Front_End_Inlining then + if Inline_Active and not Front_End_Inlining then + + -- We really should have a tag for this, what if we added a new + -- back end some day, it would not be true for this test, but it + -- would be non-GCC, so this is a bit troublesome ??? + Front_End_Inlining := VM_Target /= No_VM or else AAMP_On_Target; end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ca11c72..2a3dc45 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -3018,14 +3018,16 @@ package body Sem_Ch13 is -- of a package declaration, the pragma needs to be inserted -- in the list of declarations for the associated package. -- There is no issue of visibility delay for these aspects. - -- Aspect is legal on a local instantiation of a library- - -- level generic unit. if A_Id in Library_Unit_Aspects and then Nkind_In (N, N_Package_Declaration, N_Generic_Package_Declaration) and then Nkind (Parent (N)) /= N_Compilation_Unit + + -- Aspect is legal on a local instantiation of a library- + -- level generic unit. + and then not Is_Generic_Instance (Defining_Entity (N)) then Error_Msg_N diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index eacb977..f300e70 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6696,6 +6696,18 @@ package body Sem_Res is then return True; + -- The volatile object appears as the expression of a type conversion + -- occurring in a non-interfering context. + + elsif Nkind_In (Context, N_Type_Conversion, + N_Unchecked_Type_Conversion) + and then Expression (Context) = Obj_Ref + and then Is_OK_Volatile_Context + (Context => Parent (Context), + Obj_Ref => Context) + then + return True; + -- Allow references to volatile objects in various checks. This is -- not a direct SPARK 2014 requirement. -- 2.7.4