From 8c691dc68e9c514a6a3359cdb7cac06836ec81a8 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 20 Nov 2014 16:46:20 +0100 Subject: [PATCH] [multiple changes] 2014-11-20 Hristian Kirtchev * exp_ch3.adb (Build_Initialization_Call): Reimplement the circuitry which extraacts the [underlying] full view of a private type to handle a case where the private type acts as a generic actual. * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Inherit the loop label form the original loop regardless of whether it came from source. * sem_attr.adb (Analyze_Attribute): When taking 'Access of an expression function with a generated body that has not been analyzed yet, analyze the body to freeze the expression. * sem_util.adb (Set_Public_Status_Of): New routine. (Transfer_Entities): Handle the case where a private type with an internally generated full view is being transfered and update its full view. 2014-11-20 Vincent Celier * prj-nmsc.adb (Check_Object): If a unit is in a multi-source file, its object file is never the same as any other unit. 2014-11-20 Bob Duff * s-taskin.adb (Initialize_ATCB): Take into account the fact that the domain of the activator can be null if we're initializing a foreign task. From-SVN: r217877 --- gcc/ada/ChangeLog | 28 +++++++++++++ gcc/ada/exp_ch3.adb | 44 ++++++++++++++------ gcc/ada/exp_ch5.adb | 10 ++--- gcc/ada/prj-nmsc.adb | 18 ++++---- gcc/ada/s-taskin.adb | 15 +++++-- gcc/ada/sem_attr.adb | 30 ++++++-------- gcc/ada/sem_util.adb | 99 ++++++++++++++++++++++++++++++-------------- 7 files changed, 164 insertions(+), 80 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a3639674a50..45870c365d8 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2014-11-20 Hristian Kirtchev + + * exp_ch3.adb (Build_Initialization_Call): Reimplement the + circuitry which extraacts the [underlying] full view of a + private type to handle a case where the private type acts as a + generic actual. + * exp_ch5.adb (Expand_Iterator_Loop_Over_Array): Inherit the + loop label form the original loop regardless of whether it came + from source. + * sem_attr.adb (Analyze_Attribute): When taking 'Access of an + expression function with a generated body that has not been + analyzed yet, analyze the body to freeze the expression. + * sem_util.adb (Set_Public_Status_Of): New routine. + (Transfer_Entities): Handle the case where a private type with + an internally generated full view is being transfered and update + its full view. + +2014-11-20 Vincent Celier + + * prj-nmsc.adb (Check_Object): If a unit is in a multi-source + file, its object file is never the same as any other unit. + +2014-11-20 Bob Duff + + * s-taskin.adb (Initialize_ATCB): Take into + account the fact that the domain of the activator can be null + if we're initializing a foreign task. + 2014-11-20 Robert Dewar * sem_ch12.adb: Minor reformatting. diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 0e6c8dd755c..8bbbdc32374 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -1459,7 +1459,7 @@ package body Exp_Ch3 is Discr : Entity_Id; First_Arg : Node_Id; Full_Init_Type : Entity_Id; - Full_Type : Entity_Id := Typ; + Full_Type : Entity_Id; Init_Type : Entity_Id; Proc : Entity_Id; @@ -1490,20 +1490,38 @@ package body Exp_Ch3 is return Empty_List; end if; - -- Go to full view or underlying full view if private type. In the case - -- of successive private derivations, this can require two steps. + Full_Type := Typ; - if Is_Private_Type (Full_Type) - and then Present (Full_View (Full_Type)) - then - Full_Type := Full_View (Full_Type); - end if; + -- Use the [underlying] full view when dealing with a private type. This + -- may require several steps depending on derivations. - if Is_Private_Type (Full_Type) - and then Present (Underlying_Full_View (Full_Type)) - then - Full_Type := Underlying_Full_View (Full_Type); - end if; + loop + if Is_Private_Type (Full_Type) then + if Present (Full_View (Full_Type)) then + Full_Type := Full_View (Full_Type); + + elsif Present (Underlying_Full_View (Full_Type)) then + Full_Type := Underlying_Full_View (Full_Type); + + -- When a private type acts as a generic actual and lacks a full + -- view, use the base type. + + elsif Is_Generic_Actual_Type (Full_Type) then + Full_Type := Base_Type (Full_Type); + + -- The loop has recovered the [underlying] full view, stop the + -- traversal. + + else + exit; + end if; + + -- The type is not private, nothing to do + + else + exit; + end if; + end loop; -- If Typ is derived, the procedure is the initialization procedure for -- the root type. Wrap the argument in an conversion to make it type diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index e66a58363e9..fc6141a53ad 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -3766,14 +3766,10 @@ package body Exp_Ch5 is end loop; end if; - -- If original loop has a source name, preserve it so it can be - -- recognized by an exit statement in the body of the rewritten loop. - -- This only concerns source names: the generated name of an anonymous - -- loop will be create again during the subsequent analysis below. + -- Inherit the loop identifier from the original loop. This ensures that + -- the scope stack is consistent after the rewriting. - if Present (Identifier (N)) - and then Comes_From_Source (Identifier (N)) - then + if Present (Identifier (N)) then Set_Identifier (Core_Loop, Relocate_Node (Identifier (N))); end if; diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index b4dd7985a3f..3bfe2d837ed 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -2577,7 +2577,7 @@ package body Prj.Nmsc is Error_Msg_Name_1 := Lang_Index.Display_Name; Error_Msg (Data.Flags, - "?no compiler specified for language %%" & + "?\no compiler specified for language %%" & ", ignoring all its sources", No_Location, Project); @@ -2604,7 +2604,7 @@ package body Prj.Nmsc is if Lang_Index.Config.Naming_Data.Spec_Suffix = No_File then Error_Msg (Data.Flags, - "Spec_Suffix not specified for " & + "\Spec_Suffix not specified for " & Get_Name_String (Lang_Index.Name), No_Location, Project); end if; @@ -2612,7 +2612,7 @@ package body Prj.Nmsc is if Lang_Index.Config.Naming_Data.Body_Suffix = No_File then Error_Msg (Data.Flags, - "Body_Suffix not specified for " & + "\Body_Suffix not specified for " & Get_Name_String (Lang_Index.Name), No_Location, Project); end if; @@ -2630,7 +2630,7 @@ package body Prj.Nmsc is Error_Msg_Name_1 := Lang_Index.Display_Name; Error_Msg (Data.Flags, - "no suffixes specified for %%", + "\no suffixes specified for %%", No_Location, Project); end if; end if; @@ -3770,7 +3770,7 @@ package body Prj.Nmsc is if Switches /= No_Array_Element then Error_Msg (Data.Flags, - "?Linker switches not taken into account in library " & + "?\Linker switches not taken into account in library " & "projects", No_Location, Project); end if; @@ -6793,7 +6793,7 @@ package body Prj.Nmsc is Error_Msg_Name_2 := Source.Unit.Name; Error_Or_Warning (Data.Flags, Data.Flags.Missing_Source_Files, - "source file %% for unit %% not found", + "\source file %% for unit %% not found", No_Location, Project.Project); end if; end if; @@ -7789,7 +7789,7 @@ package body Prj.Nmsc is Error_Msg_File_1 := Source.File; Error_Msg (Data.Flags, - "{ cannot be both excluded and an exception file name", + "\{ cannot be both excluded and an exception file name", No_Location, Project.Project); end if; @@ -7936,13 +7936,15 @@ package body Prj.Nmsc is if Source /= No_Source and then Source.Replaced_By = No_Source and then Source.Path /= Src.Path + and then Source.Index = 0 + and then Src.Index = 0 and then Is_Extending (Src.Project, Source.Project) then Error_Msg_File_1 := Src.File; Error_Msg_File_2 := Source.File; Error_Msg (Data.Flags, - "{ and { have the same object file name", + "\{ and { have the same object file name", No_Location, Project.Project); else diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 310873b1288..1c18a89d43b 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -118,10 +118,17 @@ package body System.Tasking is T.Common.Base_Priority := Base_Priority; T.Common.Base_CPU := Base_CPU; - -- The Domain defaults to that of the activator - - T.Common.Domain := - (if Domain = null then Self_ID.Common.Domain else Domain); + -- The Domain defaults to that of the activator. But that can be null in + -- the case of foreign threads (see Register_Foreign_Thread), in which + -- case we default to the System_Domain. + + if Domain /= null then + T.Common.Domain := Domain; + elsif Self_ID.Common.Domain /= null then + T.Common.Domain := Self_ID.Common.Domain; + else + T.Common.Domain := System_Domain; + end if; pragma Assert (T.Common.Domain /= null); T.Common.Current_Priority := 0; diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e80531453b7..7ff79395be5 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -10517,10 +10517,8 @@ package body Sem_Attr is Scop : constant Entity_Id := Scope (Subp_Id); Subp_Decl : constant Node_Id := Unit_Declaration_Node (Subp_Id); - - Flag_Id : Entity_Id; - HSS : Node_Id; - Stmt : Node_Id; + Flag_Id : Entity_Id; + Subp_Body : Node_Id; -- If the access has been taken and the body of the subprogram -- has not been see yet, indirect calls must be protected with @@ -10571,24 +10569,20 @@ package body Sem_Attr is -- generated body is immediately analyzed and the expression -- is automatically frozen. - if Ekind (Subp_Id) = E_Function - and then Nkind (Subp_Decl) = N_Subprogram_Declaration - and then Nkind (Original_Node (Subp_Decl)) = - N_Expression_Function + if Is_Expression_Function (Subp_Id) and then Present (Corresponding_Body (Subp_Decl)) - and then not Analyzed (Corresponding_Body (Subp_Decl)) then - HSS := - Handled_Statement_Sequence - (Unit_Declaration_Node - (Corresponding_Body (Subp_Decl))); + Subp_Body := + Unit_Declaration_Node (Corresponding_Body (Subp_Decl)); - if Present (HSS) then - Stmt := First (Statements (HSS)); + -- Analyze the body of the expression function to freeze + -- the expression. This takes care of the case where the + -- 'Access is part of dispatch table initialization and + -- the generated body of the expression function has not + -- been analyzed yet. - if Nkind (Stmt) = N_Simple_Return_Statement then - Freeze_Expression (Expression (Stmt)); - end if; + if not Analyzed (Subp_Body) then + Analyze (Subp_Body); end if; end if; end; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index cc8679cab16..3ae7058c194 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -17619,48 +17619,87 @@ package body Sem_Util is ----------------------- procedure Transfer_Entities (From : Entity_Id; To : Entity_Id) is - Ent : Entity_Id := First_Entity (From); + procedure Set_Public_Status_Of (Id : Entity_Id); + -- Set the Is_Public attribute of arbitrary entity Id by calling routine + -- Set_Public_Status. If successfull and Id denotes a record type, set + -- the Is_Public attribute of its fields. + + -------------------------- + -- Set_Public_Status_Of -- + -------------------------- + + procedure Set_Public_Status_Of (Id : Entity_Id) is + Field : Entity_Id; + + begin + if not Is_Public (Id) then + Set_Public_Status (Id); + + -- When the input entity is a public record type, ensure that all + -- its internal fields are also exposed to the linker. The fields + -- of a class-wide type are never made public. + + if Is_Public (Id) + and then Is_Record_Type (Id) + and then not Is_Class_Wide_Type (Id) + then + Field := First_Entity (Id); + while Present (Field) loop + Set_Is_Public (Field); + Next_Entity (Field); + end loop; + end if; + end if; + end Set_Public_Status_Of; + + -- Local variables + + Full_Id : Entity_Id; + Id : Entity_Id; + + -- Start of processing for Transfer_Entities begin - if No (Ent) then - return; - end if; + Id := First_Entity (From); - if (Last_Entity (To)) = Empty then - Set_First_Entity (To, Ent); - else - Set_Next_Entity (Last_Entity (To), Ent); - end if; + if Present (Id) then - Set_Last_Entity (To, Last_Entity (From)); + -- Merge the entity chain of the source scope with that of the + -- destination scope. - while Present (Ent) loop - Set_Scope (Ent, To); + if Present (Last_Entity (To)) then + Set_Next_Entity (Last_Entity (To), Id); + else + Set_First_Entity (To, Id); + end if; - if not Is_Public (Ent) then - Set_Public_Status (Ent); + Set_Last_Entity (To, Last_Entity (From)); - if Is_Public (Ent) and then Ekind (Ent) = E_Record_Subtype then + -- Inspect the entities of the source scope and update their Scope + -- attribute. - -- The components of the propagated Itype must also be public + while Present (Id) loop + Set_Scope (Id, To); + Set_Public_Status_Of (Id); - declare - Comp : Entity_Id; - begin - Comp := First_Entity (Ent); - while Present (Comp) loop - Set_Is_Public (Comp); - Next_Entity (Comp); - end loop; - end; + -- Handle an internally generated full view for a private type + + if Is_Private_Type (Id) + and then Present (Full_View (Id)) + and then Is_Itype (Full_View (Id)) + then + Full_Id := Full_View (Id); + + Set_Scope (Full_Id, To); + Set_Public_Status_Of (Full_Id); end if; - end if; - Next_Entity (Ent); - end loop; + Next_Entity (Id); + end loop; - Set_First_Entity (From, Empty); - Set_Last_Entity (From, Empty); + Set_First_Entity (From, Empty); + Set_Last_Entity (From, Empty); + end if; end Transfer_Entities; ----------------------- -- 2.30.2