From: Gary Dismukes Date: Tue, 15 Nov 2005 14:03:10 +0000 (+0100) Subject: sem_ch7.adb (Install_Parent_Private_Declarations): New procedure nested within Analyz... X-Git-Tag: releases/gcc-4.1.0~800 X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=a59e9305af116b773cf8240a7f3c50c24f9aab9b;p=thirdparty%2Fgcc.git sem_ch7.adb (Install_Parent_Private_Declarations): New procedure nested within Analyze_Package_Specification to install the... 2005-11-14 Gary Dismukes Ed Schonberg * sem_ch7.adb (Install_Parent_Private_Declarations): New procedure nested within Analyze_Package_Specification to install the private declarations and use clauses within each of the parent units of a package instance of a generic child package. (Analyze_Package_Specification): When entering a private part of a package associated with a generic instance or formal package, the private declarations of the parent must be installed (by calling new procedure Install_Parent_Private_Declarations). Change name Is_Package to Is_Package_Or_Generic_Package (Preserve_Full_Attributes): For a synchronized type, the corresponding record is absent in a generic context, which does not indicate a compiler error. From-SVN: r107002 --- diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 178cfd3dd601..e538970b5a4e 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2005 Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2005, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -195,7 +195,7 @@ package body Sem_Ch7 is Spec_Id := Current_Entity_In_Scope (Defining_Entity (N)); if Present (Spec_Id) - and then Is_Package (Spec_Id) + and then Is_Package_Or_Generic_Package (Spec_Id) then Pack_Decl := Unit_Declaration_Node (Spec_Id); @@ -213,7 +213,7 @@ package body Sem_Ch7 is return; end if; - if Is_Package (Spec_Id) + if Is_Package_Or_Generic_Package (Spec_Id) and then (Scope (Spec_Id) = Standard_Standard or else Is_Child_Unit (Spec_Id)) @@ -713,6 +713,14 @@ package body Sem_Ch7 is -- the error message "Unchecked_Union may not complete discriminated -- partial view". + procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id); + -- Given the package entity of a generic package instantiation or + -- formal package whose corresponding generic is a child unit, installs + -- the private declarations of each of the child unit's parents. + -- This has to be done at the point of entering the instance package's + -- private part rather than being done in Sem_Ch12.Install_Parent + -- (which is where the parents' visible declarations are installed). + --------------------- -- Clear_Constants -- --------------------- @@ -881,6 +889,70 @@ package body Sem_Ch7 is end loop; end Inspect_Unchecked_Union_Completion; + ----------------------------------------- + -- Install_Parent_Private_Declarations -- + ----------------------------------------- + + procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id) is + Inst_Par : Entity_Id := Inst_Id; + Gen_Par : Entity_Id; + Inst_Node : Node_Id; + + begin + Gen_Par := + Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par))); + while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop + Inst_Node := Get_Package_Instantiation_Node (Inst_Par); + + if (Nkind (Inst_Node) = N_Package_Instantiation + or else Nkind (Inst_Node) = N_Formal_Package_Declaration) + and then Nkind (Name (Inst_Node)) = N_Expanded_Name + then + Inst_Par := Entity (Prefix (Name (Inst_Node))); + + if Present (Renamed_Entity (Inst_Par)) then + Inst_Par := Renamed_Entity (Inst_Par); + end if; + + Gen_Par := + Generic_Parent + (Specification (Unit_Declaration_Node (Inst_Par))); + + -- Install the private declarations and private use clauses + -- of a parent instance of the child instance. + + if Present (Gen_Par) then + Install_Private_Declarations (Inst_Par); + Set_Use (Private_Declarations + (Specification + (Unit_Declaration_Node (Inst_Par)))); + + -- If we've reached the end of the generic instance parents, + -- then finish off by looping through the nongeneric parents + -- and installing their private declarations. + + else + while Present (Inst_Par) + and then Inst_Par /= Standard_Standard + and then (not In_Open_Scopes (Inst_Par) + or else not In_Private_Part (Inst_Par)) + loop + Install_Private_Declarations (Inst_Par); + Set_Use (Private_Declarations + (Specification + (Unit_Declaration_Node (Inst_Par)))); + Inst_Par := Scope (Inst_Par); + end loop; + + exit; + end if; + + else + exit; + end if; + end loop; + end Install_Parent_Private_Declarations; + -- Start of processing for Analyze_Package_Specification begin @@ -974,6 +1046,20 @@ package body Sem_Ch7 is Install_Private_With_Clauses (Id); end if; + -- If this is a package associated with a generic instance or formal + -- package, then the private declarations of each of the generic's + -- parents must be installed at this point. + + if Is_Generic_Instance (Id) + or else + (Nkind (Unit_Declaration_Node (Id)) = N_Generic_Package_Declaration + and then + Nkind (Original_Node (Unit_Declaration_Node (Id))) + = N_Formal_Package_Declaration) + then + Install_Parent_Private_Declarations (Id); + end if; + -- Analyze private part if present. The flag In_Private_Part is -- reset in End_Package_Scope. @@ -1472,9 +1558,10 @@ package body Sem_Ch7 is Last_Entity : Entity_Id; begin - pragma Assert (Is_Package (P) or else Is_Record_Type (P)); + pragma Assert + (Is_Package_Or_Generic_Package (P) or else Is_Record_Type (P)); - if Is_Package (P) then + if Is_Package_Or_Generic_Package (P) then Last_Entity := First_Private_Entity (P); else Last_Entity := Empty; @@ -1702,8 +1789,10 @@ package body Sem_Ch7 is Set_Access_Disp_Table (Priv, Access_Disp_Table (Corresponding_Record_Type (Base_Type (Full)))); + + -- Generic context, or previous errors + else - pragma Assert (Serious_Errors_Detected > 0); null; end if;