From 3204b9cd43a75f23985533f14c6e1ff40e92c7db Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 16 Apr 2009 11:47:36 +0200 Subject: [PATCH] [multiple changes] 2009-04-16 Ed Schonberg * sem_ch12.adb (Map_Formal_Package_Entities): renamed from Map_Entities and made global, to be used when installing parents of a child instance, to provide mappings for entities declared in formal packages of ancestor units. Now called from Install_Formal_Packages. 2009-04-16 Doug Rupp * s-taskin.adb (Initialize_ATCB): Initialize Debug_Events with others notation for clarity. * s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb, s-taprop-mingw.adb, s-taprop-linux.adb, s-taprop-solaris.adb, s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-posix.adb (Initialize): Initialize Known_Tasks with Environment task. * s-taskin.ads (Task_States): Move new states to end for the sake of GDB compatibility. * s-tassta.adb (Task_Wrapper): Fix comment about Enter_Task. From-SVN: r146158 --- gcc/ada/ChangeLog | 22 +++++ gcc/ada/s-taprop-hpux-dce.adb | 6 ++ gcc/ada/s-taprop-irix.adb | 6 ++ gcc/ada/s-taprop-linux.adb | 6 ++ gcc/ada/s-taprop-mingw.adb | 7 ++ gcc/ada/s-taprop-posix.adb | 6 ++ gcc/ada/s-taprop-solaris.adb | 6 ++ gcc/ada/s-taprop-tru64.adb | 6 ++ gcc/ada/s-taprop-vms.adb | 6 ++ gcc/ada/s-taprop-vxworks.adb | 6 ++ gcc/ada/s-taskin.adb | 34 +++---- gcc/ada/s-taskin.ads | 18 +++- gcc/ada/s-tassta.adb | 3 +- gcc/ada/sem_ch12.adb | 208 +++++++++++++++++++++++++----------------- 14 files changed, 233 insertions(+), 107 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6b706bd..7748446 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,27 @@ 2009-04-16 Ed Schonberg + * sem_ch12.adb (Map_Formal_Package_Entities): renamed from Map_Entities + and made global, to be used when installing parents of a child + instance, to provide mappings for entities declared in formal packages + of ancestor units. Now called from Install_Formal_Packages. + +2009-04-16 Doug Rupp + + * s-taskin.adb (Initialize_ATCB): Initialize Debug_Events with others + notation for clarity. + + * s-taprop-vxworks.adb, s-taprop-tru64.adb, s-taprop-vms.adb, + s-taprop-mingw.adb, s-taprop-linux.adb, s-taprop-solaris.adb, + s-taprop-irix.adb, s-taprop-hpux-dce.adb, s-taprop-posix.adb + (Initialize): Initialize Known_Tasks with Environment task. + + * s-taskin.ads (Task_States): Move new states to end for the sake of + GDB compatibility. + + * s-tassta.adb (Task_Wrapper): Fix comment about Enter_Task. + +2009-04-16 Ed Schonberg + * exp_ch9.adb (Expand_N_Protected_Type_Declaration): If a protected operation has an inline pragma, propagate the flag to the internal unprotected subprogram. diff --git a/gcc/ada/s-taprop-hpux-dce.adb b/gcc/ada/s-taprop-hpux-dce.adb index 0afd56b..6288af5 100644 --- a/gcc/ada/s-taprop-hpux-dce.adb +++ b/gcc/ada/s-taprop-hpux-dce.adb @@ -1218,6 +1218,12 @@ package body System.Task_Primitives.Operations is Specific.Initialize (Environment_Task); + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); -- Install the abort-signal handler diff --git a/gcc/ada/s-taprop-irix.adb b/gcc/ada/s-taprop-irix.adb index d3344b3..2d38f6e 100644 --- a/gcc/ada/s-taprop-irix.adb +++ b/gcc/ada/s-taprop-irix.adb @@ -1303,6 +1303,12 @@ package body System.Task_Primitives.Operations is Specific.Initialize (Environment_Task); + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); -- Prepare the set of signals that should unblocked in all tasks diff --git a/gcc/ada/s-taprop-linux.adb b/gcc/ada/s-taprop-linux.adb index d3597a2..aebfcb6 100644 --- a/gcc/ada/s-taprop-linux.adb +++ b/gcc/ada/s-taprop-linux.adb @@ -1244,6 +1244,12 @@ package body System.Task_Primitives.Operations is Alternate_Stack'Address; end if; + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); -- Install the abort-signal handler diff --git a/gcc/ada/s-taprop-mingw.adb b/gcc/ada/s-taprop-mingw.adb index f32d426..cb51841 100644 --- a/gcc/ada/s-taprop-mingw.adb +++ b/gcc/ada/s-taprop-mingw.adb @@ -1069,6 +1069,13 @@ package body System.Task_Primitives.Operations is Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); Environment_Task.Common.LL.Thread := GetCurrentThread; + + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); end Initialize; diff --git a/gcc/ada/s-taprop-posix.adb b/gcc/ada/s-taprop-posix.adb index 51f20a6..d87b1e6 100644 --- a/gcc/ada/s-taprop-posix.adb +++ b/gcc/ada/s-taprop-posix.adb @@ -1423,6 +1423,12 @@ package body System.Task_Primitives.Operations is Alternate_Stack'Address; end if; + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); -- Install the abort-signal handler diff --git a/gcc/ada/s-taprop-solaris.adb b/gcc/ada/s-taprop-solaris.adb index 4156e36..795750b 100644 --- a/gcc/ada/s-taprop-solaris.adb +++ b/gcc/ada/s-taprop-solaris.adb @@ -479,6 +479,12 @@ package body System.Task_Primitives.Operations is Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); -- Install the abort-signal handler diff --git a/gcc/ada/s-taprop-tru64.adb b/gcc/ada/s-taprop-tru64.adb index 94649e2..4c55c58 100644 --- a/gcc/ada/s-taprop-tru64.adb +++ b/gcc/ada/s-taprop-tru64.adb @@ -1332,6 +1332,12 @@ package body System.Task_Primitives.Operations is Specific.Initialize (Environment_Task); + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); -- Install the abort-signal handler diff --git a/gcc/ada/s-taprop-vms.adb b/gcc/ada/s-taprop-vms.adb index cc640a8..01a77d6 100644 --- a/gcc/ada/s-taprop-vms.adb +++ b/gcc/ada/s-taprop-vms.adb @@ -1264,6 +1264,12 @@ package body System.Task_Primitives.Operations is 0 -- False, we don't have the std TCB prolog ); + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); end Initialize; diff --git a/gcc/ada/s-taprop-vxworks.adb b/gcc/ada/s-taprop-vxworks.adb index 5f6d8d4..7f823ac 100644 --- a/gcc/ada/s-taprop-vxworks.adb +++ b/gcc/ada/s-taprop-vxworks.adb @@ -1383,6 +1383,12 @@ package body System.Task_Primitives.Operations is Initialize_Lock (Single_RTS_Lock'Access, RTS_Lock_Level); + -- Make environment task known here because it doesn't go through + -- Activate_Tasks, which does it for all other tasks. + + Known_Tasks (Known_Tasks'First) := Environment_Task; + Environment_Task.Known_Tasks_Index := Known_Tasks'First; + Enter_Task (Environment_Task); end Initialize; diff --git a/gcc/ada/s-taskin.adb b/gcc/ada/s-taskin.adb index 8cc9d91..ba5ef09 100644 --- a/gcc/ada/s-taskin.adb +++ b/gcc/ada/s-taskin.adb @@ -114,25 +114,25 @@ package body System.Tasking is return; end if; - T.Common.Parent := Parent; - T.Common.Base_Priority := Base_Priority; - T.Common.Current_Priority := 0; + -- Wouldn't the following be better done using an assignment of an + -- aggregate so that we could be sure no components were forgotten??? + + T.Common.Parent := Parent; + T.Common.Base_Priority := Base_Priority; + T.Common.Current_Priority := 0; T.Common.Protected_Action_Nesting := 0; - T.Common.Call := null; - T.Common.Task_Arg := Task_Arg; - T.Common.Task_Entry_Point := Task_Entry_Point; - T.Common.Activator := Self_ID; - T.Common.Wait_Count := 0; - T.Common.Elaborated := Elaborated; - T.Common.Activation_Failed := False; - T.Common.Task_Info := Task_Info; + T.Common.Call := null; + T.Common.Task_Arg := Task_Arg; + T.Common.Task_Entry_Point := Task_Entry_Point; + T.Common.Activator := Self_ID; + T.Common.Wait_Count := 0; + T.Common.Elaborated := Elaborated; + T.Common.Activation_Failed := False; + T.Common.Task_Info := Task_Info; T.Common.Global_Task_Lock_Nesting := 0; - T.Common.Fall_Back_Handler := null; - T.Common.Specific_Handler := null; - T.Common.Debug_Events := - (False, False, False, False, False, False, False, False, - False, False, False, False, False, False, False, False); - -- Wouldn't (others => False) be clearer ??? + T.Common.Fall_Back_Handler := null; + T.Common.Specific_Handler := null; + T.Common.Debug_Events := (others => False); if T.Common.Parent = null then diff --git a/gcc/ada/s-taskin.ads b/gcc/ada/s-taskin.ads index 5912eac..5012abe 100644 --- a/gcc/ada/s-taskin.ads +++ b/gcc/ada/s-taskin.ads @@ -131,8 +131,9 @@ package System.Tasking is -- TCB initialized but not task has not been created. -- It cannot be executing. - Activating, - -- Task has been created and is being made Runnable. +-- Activating, +-- -- ??? Temporarily at end of list for GDB compatibility +-- -- Task has been created and is being made Runnable. -- Active states -- For all states from here down, the task has been activated. @@ -156,8 +157,9 @@ package System.Tasking is Acceptor_Sleep, -- Task is waiting on an accept or select with terminate - Acceptor_Delay_Sleep, - -- Task is waiting on an selective wait statement +-- Acceptor_Delay_Sleep, +-- -- ??? Temporarily at end of list for GDB compatibility +-- -- Task is waiting on an selective wait statement Entry_Caller_Sleep, -- Task is waiting on an entry call @@ -193,9 +195,15 @@ package System.Tasking is Asynchronous_Hold, -- The task has been held by Asynchronous_Task_Control.Hold_Task - Interrupt_Server_Blocked_On_Event_Flag + Interrupt_Server_Blocked_On_Event_Flag, -- The task has been blocked on a system call waiting for a -- completion event/signal to occur. + + Activating, + -- Task has been created and is being made Runnable. + + Acceptor_Delay_Sleep + -- Task is waiting on an selective wait statement ); type Call_Modes is diff --git a/gcc/ada/s-tassta.adb b/gcc/ada/s-tassta.adb index 5d4e7cb..0dd9ac3 100644 --- a/gcc/ada/s-tassta.adb +++ b/gcc/ada/s-tassta.adb @@ -1111,8 +1111,7 @@ package body System.Tasking.Stages is Stack_Guard (Self_ID, True); -- Initialize low-level TCB components, that cannot be initialized by - -- the creator. Enter_Task sets Self_ID.Known_Tasks_Index and also - -- Self_ID.LL.Thread + -- the creator. Enter_Task sets Self_ID.LL.Thread Enter_Task (Self_ID); diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index f0212e0..8087231 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -681,6 +681,19 @@ package body Sem_Ch12 is -- this field overlaps Entity, which is fine, because the whole point is -- that we don't need or want the normal Entity field in this situation. + procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id); + -- Within the generic part, entities in the formal package are + -- visible. To validate subsequent type declarations, indicate + -- the correspondence between the entities in the analyzed formal, + -- and the entities in the actual package. There are three packages + -- involved in the instantiation of a formal package: the parent + -- generic P1 which appears in the generic declaration, the fake + -- instantiation P2 which appears in the analyzed generic, and whose + -- visible entities may be used in subsequent formals, and the actual + -- P3 in the instance. To validate subsequent formals, me indicate + -- that the entities in P2 are mapped into those of P3. The mapping of + -- entities has to be done recursively for nested packages. + procedure Move_Freeze_Nodes (Out_Of : Entity_Id; After : Node_Id; @@ -2952,6 +2965,15 @@ package body Sem_Ch12 is Init_Env; Env_Installed := True; + + -- Reset renaming map for formal types. The mapping is established + -- when analyzing the generic associations, but some mappings are + -- inherited from formal packages of parent units, and these are + -- constructed when the parents are installed. + + Generic_Renamings.Set_Last (0); + Generic_Renamings_HTable.Reset; + Check_Generic_Child_Unit (Gen_Id, Parent_Installed); Gen_Unit := Entity (Gen_Id); @@ -3053,9 +3075,6 @@ package body Sem_Ch12 is -- validate an actual package, the instantiation environment is that -- of the enclosing instance. - Generic_Renamings.Set_Last (0); - Generic_Renamings_HTable.Reset; - Create_Instantiation_Source (N, Gen_Unit, False, S_Adjustment); -- Copy original generic tree, to produce text for instantiation @@ -7135,10 +7154,21 @@ package body Sem_Ch12 is ----------------------------- procedure Install_Formal_Packages (Par : Entity_Id) is - E : Entity_Id; + E : Entity_Id; + Gen : Entity_Id; + Gen_E : Entity_Id := Empty; begin E := First_Entity (Par); + + -- In we are installing an instance parent, locate the formal packages + -- of its generic parent. + + if Is_Generic_Instance (Par) then + Gen := Generic_Parent (Specification (Unit_Declaration_Node (Par))); + Gen_E := First_Entity (Gen); + end if; + while Present (E) loop if Ekind (E) = E_Package and then Nkind (Parent (E)) = N_Package_Renaming_Declaration @@ -7159,10 +7189,26 @@ package body Sem_Ch12 is then Check_Generic_Actuals (Renamed_Object (E), True); Set_Is_Hidden (E, False); + + -- Find formal package in generic unit that corresponds to + -- (instance of) formal package in instance. + + while Present (Gen_E) + and then Chars (Gen_E) /= Chars (E) + loop + Next_Entity (Gen_E); + end loop; + + if Present (Gen_E) then + Map_Formal_Package_Entities (Gen_E, E); + end if; end if; end if; Next_Entity (E); + if Present (Gen_E) then + Next_Entity (Gen_E); + end if; end loop; end Install_Formal_Packages; @@ -7397,19 +7443,6 @@ package body Sem_Ch12 is -- original generic ancestor. In that case, we recognize that the -- ultimate ancestor is the same by examining names and scopes. - procedure Map_Entities (Form : Entity_Id; Act : Entity_Id); - -- Within the generic part, entities in the formal package are - -- visible. To validate subsequent type declarations, indicate - -- the correspondence between the entities in the analyzed formal, - -- and the entities in the actual package. There are three packages - -- involved in the instantiation of a formal package: the parent - -- generic P1 which appears in the generic declaration, the fake - -- instantiation P2 which appears in the analyzed generic, and whose - -- visible entities may be used in subsequent formals, and the actual - -- P3 in the instance. To validate subsequent formals, me indicate - -- that the entities in P2 are mapped into those of P3. The mapping of - -- entities has to be done recursively for nested packages. - procedure Process_Nested_Formal (Formal : Entity_Id); -- If the current formal is declared with a box, its own formals are -- visible in the instance, as they were in the generic, and their @@ -7590,65 +7623,6 @@ package body Sem_Ch12 is end if; end Is_Instance_Of; - ------------------ - -- Map_Entities -- - ------------------ - - procedure Map_Entities (Form : Entity_Id; Act : Entity_Id) is - E1 : Entity_Id; - E2 : Entity_Id; - - begin - Set_Instance_Of (Form, Act); - - -- Traverse formal and actual package to map the corresponding - -- entities. We skip over internal entities that may be generated - -- during semantic analysis, and find the matching entities by - -- name, given that they must appear in the same order. - - E1 := First_Entity (Form); - E2 := First_Entity (Act); - while Present (E1) - and then E1 /= First_Private_Entity (Form) - loop - -- Could this test be a single condition??? - -- Seems like it could, and isn't FPE (Form) a constant anyway??? - - if not Is_Internal (E1) - and then Present (Parent (E1)) - and then not Is_Class_Wide_Type (E1) - and then not Is_Internal_Name (Chars (E1)) - then - while Present (E2) - and then Chars (E2) /= Chars (E1) - loop - Next_Entity (E2); - end loop; - - if No (E2) then - exit; - else - Set_Instance_Of (E1, E2); - - if Is_Type (E1) - and then Is_Tagged_Type (E2) - then - Set_Instance_Of - (Class_Wide_Type (E1), Class_Wide_Type (E2)); - end if; - - if Ekind (E1) = E_Package - and then No (Renamed_Object (E1)) - then - Map_Entities (E1, E2); - end if; - end if; - end if; - - Next_Entity (E1); - end loop; - end Map_Entities; - --------------------------- -- Process_Nested_Formal -- --------------------------- @@ -7734,7 +7708,7 @@ package body Sem_Ch12 is end if; Set_Instance_Of (Defining_Identifier (Formal), Actual_Pack); - Map_Entities (Formal_Pack, Actual_Pack); + Map_Formal_Package_Entities (Formal_Pack, Actual_Pack); Nod := Make_Package_Renaming_Declaration (Loc, @@ -8378,7 +8352,7 @@ package body Sem_Ch12 is "with volatile actual", Actual); end if; - -- OUT not present + -- formal in-parameter else -- The instantiation of a generic formal in-parameter is constant @@ -8426,11 +8400,15 @@ package body Sem_Ch12 is end if; declare - Typ : constant Entity_Id := - Get_Instance_Of - (Etype (Defining_Identifier (Analyzed_Formal))); + Formal_Object : constant Entity_Id := + Defining_Identifier (Analyzed_Formal); + Formal_Type : constant Entity_Id := Etype (Formal_Object); + + Typ : Entity_Id; begin + Typ := Get_Instance_Of (Formal_Type); + Freeze_Before (Instantiation_Node, Typ); -- If the actual is an aggregate, perform name resolution on @@ -10722,6 +10700,70 @@ package body Sem_Ch12 is end if; end Load_Parent_Of_Generic; + --------------------------------- + -- Map_Formal_Package_Entities -- + --------------------------------- + + procedure Map_Formal_Package_Entities (Form : Entity_Id; Act : Entity_Id) is + E1 : Entity_Id; + E2 : Entity_Id; + + begin + Set_Instance_Of (Form, Act); + + -- Traverse formal and actual package to map the corresponding entities. + -- We skip over internal entities that may be generated during semantic + -- analysis, and find the matching entities by name, given that they + -- must appear in the same order. + + E1 := First_Entity (Form); + E2 := First_Entity (Act); + while Present (E1) + and then E1 /= First_Private_Entity (Form) + loop + -- Could this test be a single condition??? + -- Seems like it could, and isn't FPE (Form) a constant anyway??? + + if not Is_Internal (E1) + and then Present (Parent (E1)) + and then not Is_Class_Wide_Type (E1) + and then not Is_Internal_Name (Chars (E1)) + then + while Present (E2) + and then Chars (E2) /= Chars (E1) + loop + Next_Entity (E2); + end loop; + + if No (E2) then + exit; + else + Set_Instance_Of (E1, E2); + + if Is_Type (E1) + and then Is_Tagged_Type (E2) + then + Set_Instance_Of + (Class_Wide_Type (E1), Class_Wide_Type (E2)); + end if; + + if Is_Constrained (E1) then + Set_Instance_Of + (Base_Type (E1), Base_Type (E2)); + end if; + + if Ekind (E1) = E_Package + and then No (Renamed_Object (E1)) + then + Map_Formal_Package_Entities (E1, E2); + end if; + end if; + end if; + + Next_Entity (E1); + end loop; + end Map_Formal_Package_Entities; + ----------------------- -- Move_Freeze_Nodes -- ----------------------- @@ -10737,8 +10779,8 @@ package body Sem_Ch12 is Spec : Node_Id; function Is_Outer_Type (T : Entity_Id) return Boolean; - -- Check whether entity is declared in a scope external to that - -- of the generic unit. + -- Check whether entity is declared in a scope external to that of the + -- generic unit. ------------------- -- Is_Outer_Type -- -- 2.7.4