From: Arnaud Charlet Date: Mon, 24 Oct 2011 09:28:21 +0000 (+0200) Subject: [multiple changes] X-Git-Tag: releases/gcc-4.7.0~2867 X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=292689c213a6cbf75983bf9274b2a336ae0ae910;p=thirdparty%2Fgcc.git [multiple changes] 2011-10-24 Emmanuel Briot * prj-proc.adb (Process_Expression_Variable_Decl): No special handling for Project_Path unless it is an attribute. 2011-10-24 Javier Miranda * sem_ch12.adb (Check_Hidden_Primitives): New subprogram. (Install_Hidden_Primitives): New subprogram. (Restore_Hidden_Primitives): New subprogram. (Analyze_Formal_Package_Declaration, Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation): Invoke Check_Hidden_Primitives after every call to Analyze_Associations, and invoke Restore_Hidden_Primitives to restore their visibility after processing the instantiation. (Instantiate_Package_Body): Install visible primitives before analyzing the instantiation and uninstall them to restore their visibility when the instantiation has been analyzed. * sem_util.ads, sem_util.adb (Add_Suffix): New subprogram (Remove_Suffix): New subprogram * sem_ch3.adb (Derive_Subprogram): When handling a derived subprogram for the instantiation of a formal derived tagged type, inherit the dispatching attributes from the actual subprogram (not from the parent type). From-SVN: r180370 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6eec150a7e2b..3a21df4383ef 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,28 @@ +2011-10-24 Emmanuel Briot + + * prj-proc.adb (Process_Expression_Variable_Decl): No special + handling for Project_Path unless it is an attribute. + +2011-10-24 Javier Miranda + + * sem_ch12.adb (Check_Hidden_Primitives): New subprogram. + (Install_Hidden_Primitives): New subprogram. + (Restore_Hidden_Primitives): New subprogram. + (Analyze_Formal_Package_Declaration, + Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation): + Invoke Check_Hidden_Primitives after every call to + Analyze_Associations, and invoke Restore_Hidden_Primitives to + restore their visibility after processing the instantiation. + (Instantiate_Package_Body): Install visible primitives before + analyzing the instantiation and uninstall them to restore their + visibility when the instantiation has been analyzed. + * sem_util.ads, sem_util.adb (Add_Suffix): New subprogram + (Remove_Suffix): New subprogram + * sem_ch3.adb (Derive_Subprogram): When handling + a derived subprogram for the instantiation of a formal derived + tagged type, inherit the dispatching attributes from the actual + subprogram (not from the parent type). + 2011-10-24 Vasiliy Fofanov * gnat_ugn.texi: Document explicit use of XDECGNAT library. diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index a46ee23bb364..8e5060be243d 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -2053,7 +2053,7 @@ package body Prj.Proc is Shared.Variable_Elements.Table (Var).Value := New_Value; end if; - if Name = Snames.Name_Project_Path then + if Is_Attribute and then Name = Snames.Name_Project_Path then if In_Tree.Is_Root_Tree then declare Val : String_List_Id := New_Value.Values; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index b1963f3fdd41..befd210ccb20 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -29,6 +29,7 @@ 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; @@ -399,6 +400,13 @@ package body Sem_Ch12 is -- package cannot be inlined by the front-end because front-end inlining -- requires a strict linear order of elaboration. + function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id; + -- Check if some association between formals and actuals requires to make + -- visible primitives of a tagged type, and make those primitives visible. + -- Return the list of primitives whose visibility is modified (to restore + -- their visibility later through Restore_Hidden_Primitives). If no + -- candidate is found then return No_Elist. + procedure Check_Hidden_Child_Unit (N : Node_Id; Gen_Unit : Entity_Id; @@ -556,6 +564,18 @@ package body Sem_Ch12 is procedure Remove_Parent (In_Body : Boolean := False); -- Reverse effect after instantiation of child is complete + procedure Install_Hidden_Primitives + (Prims_List : in out Elist_Id; + Gen_T : Entity_Id; + Act_T : Entity_Id); + -- Remove suffix 'P' from hidden primitives of Act_T to match the + -- visibility of primitives of Gen_T. The list of primitives to which + -- the suffix is removed is added to Prims_List to restore them later. + + procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id); + -- Restore suffix 'P' to primitives of Prims_List and leave Prims_List + -- set to No_Elist. + procedure Inline_Instance_Body (N : Node_Id; Gen_Unit : Entity_Id; @@ -884,7 +904,6 @@ package body Sem_Ch12 is Formals : List_Id; F_Copy : List_Id) return List_Id is - Actual_Types : constant Elist_Id := New_Elmt_List; Assoc : constant List_Id := New_List; Default_Actuals : constant Elist_Id := New_Elmt_List; @@ -2039,6 +2058,10 @@ package body Sem_Ch12 is Renaming_In_Par : Entity_Id; Associations : Boolean := True; + Vis_Prims_List : Elist_Id := No_Elist; + -- List of primitives made temporarily visible in the instantiation + -- to match the visibility of the formal type + function Build_Local_Package return Node_Id; -- The formal package is rewritten so that its parameters are replaced -- with corresponding declarations. For parameters with bona fide @@ -2124,9 +2147,11 @@ package body Sem_Ch12 is Decls := Analyze_Associations - (Original_Node (N), - Generic_Formal_Declarations (Act_Tree), - Generic_Formal_Declarations (Gen_Decl)); + (I_Node => Original_Node (N), + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl)); + + Vis_Prims_List := Check_Hidden_Primitives (Decls); end; end if; @@ -2263,6 +2288,7 @@ package body Sem_Ch12 is Enter_Name (Formal); Set_Ekind (Formal, E_Variable); Set_Etype (Formal, Any_Type); + Restore_Hidden_Primitives (Vis_Prims_List); if Parent_Installed then Remove_Parent; @@ -2336,6 +2362,7 @@ package body Sem_Ch12 is end; End_Package_Scope (Formal); + Restore_Hidden_Primitives (Vis_Prims_List); if Parent_Installed then Remove_Parent; @@ -3131,6 +3158,12 @@ package body Sem_Ch12 is return False; end Might_Inline_Subp; + -- Local declarations + + Vis_Prims_List : Elist_Id := No_Elist; + -- List of primitives made temporarily visible in the instantiation + -- to match the visibility of the formal type + -- Start of processing for Analyze_Package_Instantiation begin @@ -3308,9 +3341,11 @@ package body Sem_Ch12 is Renaming_List := Analyze_Associations - (N, - Generic_Formal_Declarations (Act_Tree), - Generic_Formal_Declarations (Gen_Decl)); + (I_Node => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl)); + + Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); Set_Instance_Env (Gen_Unit, Act_Decl_Id); Set_Defining_Unit_Name (Act_Spec, Act_Decl_Name); @@ -3696,6 +3731,7 @@ package body Sem_Ch12 is Check_Formal_Packages (Act_Decl_Id); + Restore_Hidden_Primitives (Vis_Prims_List); Restore_Private_Views (Act_Decl_Id); Inherit_Context (Gen_Decl, N); @@ -4277,6 +4313,12 @@ package body Sem_Ch12 is end if; end Analyze_Instance_And_Renamings; + -- Local variables + + Vis_Prims_List : Elist_Id := No_Elist; + -- List of primitives made temporarily visible in the instantiation + -- to match the visibility of the formal type + -- Start of processing for Analyze_Subprogram_Instantiation begin @@ -4376,6 +4418,7 @@ package body Sem_Ch12 is Error_Msg_NE ("circular Instantiation: & instantiated in &!", N, Gen_Unit); Circularity_Detected := True; + Restore_Hidden_Primitives (Vis_Prims_List); goto Leave; end if; @@ -4402,9 +4445,11 @@ package body Sem_Ch12 is Renaming_List := Analyze_Associations - (N, - Generic_Formal_Declarations (Act_Tree), - Generic_Formal_Declarations (Gen_Decl)); + (I_Node => N, + Formals => Generic_Formal_Declarations (Act_Tree), + F_Copy => Generic_Formal_Declarations (Gen_Decl)); + + Vis_Prims_List := Check_Hidden_Primitives (Renaming_List); -- The subprogram itself cannot contain a nested instance, so the -- current parent is left empty. @@ -4554,6 +4599,7 @@ package body Sem_Ch12 is Remove_Parent; end if; + Restore_Hidden_Primitives (Vis_Prims_List); Restore_Env; Env_Installed := False; Generic_Renamings.Set_Last (0); @@ -5856,6 +5902,49 @@ package body Sem_Ch12 is end if; end Check_Private_View; + ----------------------------- + -- Check_Hidden_Primitives -- + ----------------------------- + + function Check_Hidden_Primitives (Assoc_List : List_Id) return Elist_Id is + Actual : Node_Id; + Gen_T : Entity_Id; + Result : Elist_Id := No_Elist; + + begin + if No (Assoc_List) then + return No_Elist; + end if; + + -- Traverse the list of associations between formals and actuals + -- searching for renamings of tagged types + + Actual := First (Assoc_List); + while Present (Actual) loop + if Nkind (Actual) = N_Subtype_Declaration then + Gen_T := Generic_Parent_Type (Actual); + + if Present (Gen_T) + and then Is_Tagged_Type (Gen_T) + then + -- Traverse the list of primitives of the actual types + -- searching for hidden primitives that are visible in the + -- corresponding generic formal; leave them visible and + -- append them to Result to restore their decoration later. + + Install_Hidden_Primitives + (Prims_List => Result, + Gen_T => Gen_T, + Act_T => Entity (Subtype_Indication (Actual))); + end if; + end if; + + Next (Actual); + end loop; + + return Result; + end Check_Hidden_Primitives; + -------------------------- -- Contains_Instance_Of -- -------------------------- @@ -7893,6 +7982,138 @@ package body Sem_Ch12 is end if; end Install_Parent; + ------------------------------- + -- Install_Hidden_Primitives -- + ------------------------------- + + procedure Install_Hidden_Primitives + (Prims_List : in out Elist_Id; + Gen_T : Entity_Id; + Act_T : Entity_Id) + is + Elmt : Elmt_Id; + List : Elist_Id := No_Elist; + Prim_G_Elmt : Elmt_Id; + Prim_A_Elmt : Elmt_Id; + Prim_G : Node_Id; + Prim_A : Node_Id; + + begin + -- No action needed in case of serious errors because we cannot trust + -- in the order of primitives + + if Serious_Errors_Detected > 0 then + return; + + -- No action possible if we don't have available the list of primitive + -- operations + + elsif No (Gen_T) + or else not Is_Record_Type (Gen_T) + or else not Is_Tagged_Type (Gen_T) + or else not Is_Record_Type (Act_T) + or else not Is_Tagged_Type (Act_T) + then + return; + + -- There is no need to handle interface types since their primitives + -- cannot be hidden + + elsif Is_Interface (Gen_T) then + return; + end if; + + Prim_G_Elmt := First_Elmt (Primitive_Operations (Gen_T)); + + if not Is_Class_Wide_Type (Act_T) then + Prim_A_Elmt := First_Elmt (Primitive_Operations (Act_T)); + else + Prim_A_Elmt := First_Elmt (Primitive_Operations (Root_Type (Act_T))); + end if; + + loop + -- Skip predefined primitives in the generic formal + + while Present (Prim_G_Elmt) + and then Is_Predefined_Dispatching_Operation (Node (Prim_G_Elmt)) + loop + Next_Elmt (Prim_G_Elmt); + end loop; + + -- Skip predefined primitives in the generic actual + + while Present (Prim_A_Elmt) + and then Is_Predefined_Dispatching_Operation (Node (Prim_A_Elmt)) + loop + Next_Elmt (Prim_A_Elmt); + end loop; + + exit when No (Prim_G_Elmt) or else No (Prim_A_Elmt); + + Prim_G := Node (Prim_G_Elmt); + Prim_A := Node (Prim_A_Elmt); + + -- There is no need to handle interface primitives because their + -- primitives are not hidden + + exit when Present (Interface_Alias (Prim_G)); + + if Chars (Prim_G) /= Chars (Prim_A) + and then Has_Suffix (Prim_A, 'P') + and then Remove_Suffix (Prim_A, 'P') = Chars (Prim_G) + then + Set_Chars (Prim_A, Chars (Prim_G)); + + if List = No_Elist then + List := New_Elmt_List; + end if; + + Append_Elmt (Prim_A, List); + end if; + + Next_Elmt (Prim_A_Elmt); + Next_Elmt (Prim_G_Elmt); + end loop; + + -- Append the elements to the list of temporarily visible primitives + -- avoiding duplicates + + if Present (List) then + if No (Prims_List) then + Prims_List := New_Elmt_List; + end if; + + Elmt := First_Elmt (List); + while Present (Elmt) loop + Append_Unique_Elmt (Node (Elmt), Prims_List); + Next_Elmt (Elmt); + end loop; + end if; + end Install_Hidden_Primitives; + + ------------------------------- + -- Restore_Hidden_Primitives -- + ------------------------------- + + procedure Restore_Hidden_Primitives (Prims_List : in out Elist_Id) is + Prim_Elmt : Elmt_Id; + Prim : Node_Id; + + begin + if Prims_List /= No_Elist then + Prim_Elmt := First_Elmt (Prims_List); + + while Present (Prim_Elmt) loop + Prim := Node (Prim_Elmt); + Set_Chars (Prim, Add_Suffix (Prim, 'P')); + + Next_Elmt (Prim_Elmt); + end loop; + + Prims_List := No_Elist; + end if; + end Restore_Hidden_Primitives; + -------------------------------- -- Instantiate_Formal_Package -- -------------------------------- @@ -9065,6 +9286,10 @@ package body Sem_Ch12 is Par_Ent : Entity_Id := Empty; Par_Vis : Boolean := False; + Vis_Prims_List : Elist_Id := No_Elist; + -- List of primitives made temporarily visible in the instantiation + -- to match the visibility of the formal type + begin Gen_Body_Id := Corresponding_Body (Gen_Decl); @@ -9134,6 +9359,29 @@ package body Sem_Ch12 is Set_Corresponding_Spec (Act_Body, Act_Decl_Id); Check_Generic_Actuals (Act_Decl_Id, False); + -- Install primitives hidden at the point of the instantiation but + -- visible when processing the generic formals + + declare + E : Entity_Id; + + begin + E := First_Entity (Act_Decl_Id); + while Present (E) loop + if Is_Type (E) + and then Is_Generic_Actual_Type (E) + and then Is_Tagged_Type (E) + then + Install_Hidden_Primitives + (Prims_List => Vis_Prims_List, + Gen_T => Generic_Parent_Type (Parent (E)), + Act_T => E); + end if; + + Next_Entity (E); + end loop; + end; + -- If it is a child unit, make the parent instance (which is an -- instance of the parent of the generic) visible. The parent -- instance is the prefix of the name of the generic unit. @@ -9226,6 +9474,7 @@ package body Sem_Ch12 is Set_Is_Immediately_Visible (Par_Ent, Par_Vis); end if; + Restore_Hidden_Primitives (Vis_Prims_List); Restore_Private_Views (Act_Decl_Id); -- Remove the current unit from visibility if this is an instance diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 98a032f425d1..488e6dc98cc1 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -13318,18 +13318,18 @@ package body Sem_Ch3 is -- Check for case of a derived subprogram for the instantiation of a -- formal derived tagged type, if so mark the subprogram as dispatching - -- and inherit the dispatching attributes of the parent subprogram. The + -- and inherit the dispatching attributes of the actual subprogram. The -- derived subprogram is effectively renaming of the actual subprogram, -- so it needs to have the same attributes as the actual. if Present (Actual_Subp) - and then Is_Dispatching_Operation (Parent_Subp) + and then Is_Dispatching_Operation (Actual_Subp) then Set_Is_Dispatching_Operation (New_Subp); - if Present (DTC_Entity (Parent_Subp)) then - Set_DTC_Entity (New_Subp, DTC_Entity (Parent_Subp)); - Set_DT_Position (New_Subp, DT_Position (Parent_Subp)); + if Present (DTC_Entity (Actual_Subp)) then + Set_DTC_Entity (New_Subp, DTC_Entity (Actual_Subp)); + Set_DT_Position (New_Subp, DT_Position (Actual_Subp)); end if; end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 99667d0b060b..9dfecd3d956f 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5965,6 +5965,29 @@ package body Sem_Util is return Name_Buffer (Name_Len) = Suffix; end Has_Suffix; + ---------------- + -- Add_Suffix -- + ---------------- + + function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is + begin + Get_Name_String (Chars (E)); + Add_Char_To_Name_Buffer (Suffix); + return Name_Find; + end Add_Suffix; + + ------------------- + -- Remove_Suffix -- + ------------------- + + function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id is + begin + pragma Assert (Has_Suffix (E, Suffix)); + Get_Name_String (Chars (E)); + Name_Len := Name_Len - 1; + return Name_Find; + end Remove_Suffix; + -------------------------- -- Has_Tagged_Component -- -------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index eb3528a1a797..c7f610d52f04 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -691,6 +691,12 @@ package Sem_Util is function Has_Suffix (E : Entity_Id; Suffix : Character) return Boolean; -- Returns true if the last character of E is Suffix. Used in Assertions. + function Add_Suffix (E : Entity_Id; Suffix : Character) return Name_Id; + -- Returns the name of E adding Suffix + + function Remove_Suffix (E : Entity_Id; Suffix : Character) return Name_Id; + -- Returns the name of E without Suffix + function Has_Tagged_Component (Typ : Entity_Id) return Boolean; -- Returns True if Typ is a composite type (array or record) which is -- either itself a tagged type, or has a component (recursively) which is