diff options
author | Ed Schonberg <schonberg@adacore.com> | 2007-08-14 10:46:18 +0200 |
---|---|---|
committer | Arnaud Charlet <charlet@gcc.gnu.org> | 2007-08-14 10:46:18 +0200 |
commit | 1c0ce9d83b5935bdba514340ef498c4bb73cfb78 (patch) | |
tree | 9b937a5c8f93ec82861ab5daedf9a3635ca174ab /gcc | |
parent | 1d6f10a19473c4c174bcb8295163be080ae6f64e (diff) | |
download | gcc-1c0ce9d83b5935bdba514340ef498c4bb73cfb78.zip gcc-1c0ce9d83b5935bdba514340ef498c4bb73cfb78.tar.gz gcc-1c0ce9d83b5935bdba514340ef498c4bb73cfb78.tar.bz2 |
sem_ch12.ads, [...] (Instantiate_Type): If the formal is a derived type with interface progenitors use the analyzed...
2007-08-14 Ed Schonberg <schonberg@adacore.com>
Gary Dismukes <dismukes@adacore.com>
Thomas Quinot <quinot@adacore.com>
* sem_ch12.ads, sem_ch12.adb (Instantiate_Type): If the formal is a
derived type with interface progenitors use the analyzed formal as the
parent of the actual, to create renamings for all the inherited
operations in Derive_Subprograms.
(Collect_Previous_Instances): new procedure within of
Load_Parent_Of_Generic, to instantiate all bodies in the compilation
unit being loaded, to ensure that the generation of global symbols is
consistent in different compilation modes.
(Is_Tagged_Ancestor): New function testing the ancestor relation that
takes progenitor types into account.
(Validate_Derived_Type_Instance): Enforce the rule of 3.9.3(9) by
traversing over the primitives of the formal and actual types to locate
any abstract subprograms of the actual type that correspond to a
nonabstract subprogram of the formal type's ancestor type(s), and issue
an error if such is found.
(Analyze_Package_Instantiation, Analyze_Subprogram_Instantiation,
Instantiate_Package_Body, Instantiate_Subprogram_Body):
Remove bogus guard around calls to Inherit_Context.
(Reset_Entity): If the entity is the selector of a selected component
that denotes a named number, propagate constant-folding to the generic
template only if the named number is global to the generic unit.
(Set_Instance_Env): Only reset the compilation switches when compiling
a predefined or internal unit.
From-SVN: r127443
Diffstat (limited to 'gcc')
-rw-r--r-- | gcc/ada/sem_ch12.adb | 731 | ||||
-rw-r--r-- | gcc/ada/sem_ch12.ads | 28 |
2 files changed, 598 insertions, 161 deletions
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index d3eb0f8..fc649dc 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -613,25 +613,32 @@ package body Sem_Ch12 is function Is_In_Main_Unit (N : Node_Id) return Boolean; -- Test if given node is in the main unit - procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id); - -- If the generic appears in a separate non-generic library unit, - -- load the corresponding body to retrieve the body of the generic. - -- N is the node for the generic instantiation, Spec is the generic - -- package declaration. + procedure Load_Parent_Of_Generic + (N : Node_Id; + Spec : Node_Id; + Body_Optional : Boolean := False); + -- If the generic appears in a separate non-generic library unit, load the + -- corresponding body to retrieve the body of the generic. N is the node + -- for the generic instantiation, Spec is the generic package declaration. + -- + -- Body_Optional is a flag that indicates that the body is being loaded to + -- ensure that temporaries are generated consistently when there are other + -- instances in the current declarative part that precede the one being + -- loaded. In that case a missing body is acceptable. procedure Inherit_Context (Gen_Decl : Node_Id; Inst : Node_Id); - -- Add the context clause of the unit containing a generic unit to - -- an instantiation that is a compilation unit. + -- Add the context clause of the unit containing a generic unit to an + -- instantiation that is a compilation unit. function Get_Associated_Node (N : Node_Id) return Node_Id; - -- In order to propagate semantic information back from the analyzed - -- copy to the original generic, we maintain links between selected nodes - -- in the generic and their corresponding copies. At the end of generic - -- analysis, the routine Save_Global_References traverses the generic - -- tree, examines the semantic information, and preserves the links to - -- those nodes that contain global information. At instantiation, the - -- information from the associated node is placed on the new copy, so - -- that name resolution is not repeated. + -- In order to propagate semantic information back from the analyzed copy + -- to the original generic, we maintain links between selected nodes in the + -- generic and their corresponding copies. At the end of generic analysis, + -- the routine Save_Global_References traverses the generic tree, examines + -- the semantic information, and preserves the links to those nodes that + -- contain global information. At instantiation, the information from the + -- associated node is placed on the new copy, so that name resolution is + -- not repeated. -- -- Three kinds of source nodes have associated nodes: -- @@ -651,9 +658,9 @@ package body Sem_Ch12 is -- For aggregates, the associated node allows retrieval of the type, which -- may otherwise not appear in the generic. The view of this type may be -- different between generic and instantiation, and the full view can be - -- installed before the instantiation is analyzed. For aggregates of - -- type extensions, the same view exchange may have to be performed for - -- some of the ancestor types, if their view is private at the point of + -- installed before the instantiation is analyzed. For aggregates of type + -- extensions, the same view exchange may have to be performed for some of + -- the ancestor types, if their view is private at the point of -- instantiation. -- -- Nodes that are selected components in the parse tree may be rewritten @@ -692,9 +699,9 @@ package body Sem_Ch12 is ------------------------------------------- -- The map Generic_Renamings associates generic entities with their - -- corresponding actuals. Currently used to validate type instances. - -- It will eventually be used for all generic parameters to eliminate - -- the need for overload resolution in the instance. + -- corresponding actuals. Currently used to validate type instances. It + -- will eventually be used for all generic parameters to eliminate the + -- need for overload resolution in the instance. type Assoc_Ptr is new Int; @@ -996,6 +1003,10 @@ package body Sem_Ch12 is Actual := First_Named; end if; + if Is_Entity_Name (Act) and then Present (Entity (Act)) then + Set_Used_As_Generic_Actual (Entity (Act)); + end if; + return Act; end Matching_Actual; @@ -1494,7 +1505,7 @@ package body Sem_Ch12 is then Error_Msg_N ("in a formal, a subtype indication can only be " - & "a subtype mark ('R'M 12.5.3(3))", + & "a subtype mark (RM 12.5.3(3))", Subtype_Indication (Component_Definition (Def))); end if; @@ -2828,8 +2839,7 @@ package body Sem_Ch12 is begin if not Delay_Subprogram_Descriptors (E) then Set_Delay_Subprogram_Descriptors (E); - Pending_Descriptor.Increment_Last; - Pending_Descriptor.Table (Pending_Descriptor.Last) := E; + Pending_Descriptor.Append (E); end if; end Delay_Descriptors; @@ -3121,12 +3131,12 @@ package body Sem_Ch12 is end if; -- If the current scope is itself an instance within a child - -- unit,there will be duplications in the scope stack, and the + -- unit, there will be duplications in the scope stack, and the -- unstacking mechanism in Inline_Instance_Body will fail. -- This loses some rare cases of optimization, and might be -- improved some day, if we can find a proper abstraction for -- "the complete compilation context" that can be saved and - -- restored ??? + -- restored. ??? if Is_Generic_Instance (Current_Scope) then declare @@ -3168,7 +3178,7 @@ package body Sem_Ch12 is -- instantiated is declared within a formal package, there is no -- body to instantiate until the enclosing generic is instantiated -- and there is an actual for the formal package. If the formal - -- package has parameters, we build regular package instance for + -- package has parameters, we build a regular package instance for -- it, that preceeds the original formal package declaration. if In_Open_Scopes (Scope (Scope (Gen_Unit))) then @@ -3248,9 +3258,9 @@ package body Sem_Ch12 is elsif Is_Generic_Subprogram (Enclosing_Master) or else Ekind (Enclosing_Master) = E_Void then - -- Cleanup actions will eventually be performed on - -- the enclosing instance, if any. enclosing scope - -- is void in the formal part of a generic subp. + -- Cleanup actions will eventually be performed on the + -- enclosing instance, if any. Enclosing scope is void + -- in the formal part of a generic subprogram. exit Scope_Loop; @@ -3296,9 +3306,13 @@ package body Sem_Ch12 is -- Make entry in table - Pending_Instantiations.Increment_Last; - Pending_Instantiations.Table (Pending_Instantiations.Last) := - (N, Act_Decl, Expander_Active, Current_Sem_Unit); + Pending_Instantiations.Append + ((Inst_Node => N, + Act_Decl => Act_Decl, + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); end if; end if; @@ -3310,8 +3324,8 @@ package body Sem_Ch12 is Set_Instance_Spec (N, Act_Decl); - -- If not a compilation unit, insert the package declaration - -- before the original instantiation node. + -- If not a compilation unit, insert the package declaration before + -- the original instantiation node. if Nkind (Parent (N)) /= N_Compilation_Unit then Mark_Rewrite_Insertion (Act_Decl); @@ -3320,7 +3334,7 @@ package body Sem_Ch12 is -- For an instantiation that is a compilation unit, place declaration -- on current node so context is complete for analysis (including - -- nested instantiations). It this is the main unit, the declaration + -- nested instantiations). If this is the main unit, the declaration -- eventually replaces the instantiation node. If the instance body -- is later created, it replaces the instance node, and the declation -- is attached to it (see Build_Instance_Compilation_Unit_Nodes). @@ -3360,6 +3374,7 @@ package body Sem_Ch12 is if ABE_Is_Certain (N) and then Needs_Body then Pending_Instantiations.Decrement_Last; end if; + Check_Hidden_Child_Unit (N, Gen_Unit, Act_Decl_Id); Set_First_Private_Entity (Defining_Unit_Name (Unit_Renaming), @@ -3386,9 +3401,7 @@ package body Sem_Ch12 is Restore_Private_Views (Act_Decl_Id); - if not Generic_Separately_Compiled (Gen_Unit) then - Inherit_Context (Gen_Decl, N); - end if; + Inherit_Context (Gen_Decl, N); if Parent_Installed then Remove_Parent; @@ -3415,7 +3428,7 @@ package body Sem_Ch12 is -- The following is a tree patch for ASIS: ASIS needs separate nodes to -- be used as defining identifiers for a formal package and for the - -- corresponding expanded package + -- corresponding expanded package. if Nkind (N) = N_Formal_Package_Declaration then Act_Decl_Id := New_Copy (Defining_Entity (N)); @@ -3597,7 +3610,15 @@ package body Sem_Ch12 is Push_Scope (Standard_Standard); Scope_Stack.Table (Scope_Stack.Last).Is_Active_Stack_Base := True; Instantiate_Package_Body - ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True); + (Body_Info => + ((Inst_Node => N, + Act_Decl => Act_Decl, + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), + Inlined_Body => True); + Pop_Scope; -- Restore context @@ -3704,7 +3725,14 @@ package body Sem_Ch12 is else Instantiate_Package_Body - ((N, Act_Decl, Expander_Active, Current_Sem_Unit), True); + (Body_Info => + ((Inst_Node => N, + Act_Decl => Act_Decl, + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)), + Inlined_Body => True); end if; end Inline_Instance_Body; @@ -4099,9 +4127,7 @@ package body Sem_Ch12 is Validate_Categorization_Dependency (N, Act_Decl_Id); if not Is_Intrinsic_Subprogram (Act_Decl_Id) then - if not Generic_Separately_Compiled (Gen_Unit) then - Inherit_Context (Gen_Decl, N); - end if; + Inherit_Context (Gen_Decl, N); Restore_Private_Views (Pack_Id, False); @@ -4117,9 +4143,14 @@ package body Sem_Ch12 is and then not ABE_Is_Certain (N) and then not Is_Eliminated (Act_Decl_Id) then - Pending_Instantiations.Increment_Last; - Pending_Instantiations.Table (Pending_Instantiations.Last) := - (N, Act_Decl, Expander_Active, Current_Sem_Unit); + Pending_Instantiations.Append + ((Inst_Node => N, + Act_Decl => Act_Decl, + Expander_Status => Expander_Active, + Current_Sem_Unit => Current_Sem_Unit, + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => Local_Suppress_Stack_Top)); + Check_Forward_Instantiation (Gen_Decl); -- The wrapper package is always delayed, because it does not @@ -5747,10 +5778,11 @@ package body Sem_Ch12 is Subunit := Cunit (Unum); if Nkind (Unit (Subunit)) /= N_Subunit then - Error_Msg_Sloc := Sloc (N); Error_Msg_N - ("expected SEPARATE subunit to complete stub at#," - & " found child unit", Subunit); + ("found child unit instead of expected SEPARATE subunit", + Subunit); + Error_Msg_Sloc := Sloc (N); + Error_Msg_N ("\to complete stub #", Subunit); goto Subunit_Not_Found; end if; @@ -6578,8 +6610,7 @@ package body Sem_Ch12 is Save_Opt_Config_Switches (Saved.Switches); - Instance_Envs.Increment_Last; - Instance_Envs.Table (Instance_Envs.Last) := Saved; + Instance_Envs.Append (Saved); Exchanged_Views := New_Elmt_List; Hidden_Entities := New_Elmt_List; @@ -8335,8 +8366,9 @@ package body Sem_Ch12 is ------------------------------ procedure Instantiate_Package_Body - (Body_Info : Pending_Body_Info; - Inlined_Body : Boolean := False) + (Body_Info : Pending_Body_Info; + Inlined_Body : Boolean := False; + Body_Optional : Boolean := False) is Act_Decl : constant Node_Id := Body_Info.Act_Decl; Inst_Node : constant Node_Id := Body_Info.Inst_Node; @@ -8369,8 +8401,17 @@ package body Sem_Ch12 is Expander_Mode_Save_And_Set (Body_Info.Expander_Status); + -- Re-establish the state of information on which checks are suppressed. + -- This information was set in Body_Info at the point of instantiation, + -- and now we restore it so that the instance is compiled using the + -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). + + Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; + Scope_Suppress := Body_Info.Scope_Suppress; + if No (Gen_Body_Id) then - Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl)); + Load_Parent_Of_Generic + (Inst_Node, Specification (Gen_Decl), Body_Optional); Gen_Body_Id := Corresponding_Body (Gen_Decl); end if; @@ -8491,9 +8532,7 @@ package body Sem_Ch12 is end if; end if; - if not Generic_Separately_Compiled (Gen_Unit) then - Inherit_Context (Gen_Body, Inst_Node); - end if; + Inherit_Context (Gen_Body, Inst_Node); -- Remove the parent instances if they have been placed on the scope -- stack to compile the body. @@ -8518,7 +8557,9 @@ package body Sem_Ch12 is -- complaint is suppressed if we have detected other errors (since a -- common reason for missing the body is that it had errors). - elsif Unit_Requires_Body (Gen_Unit) then + elsif Unit_Requires_Body (Gen_Unit) + and then not Body_Optional + then if Serious_Errors_Detected = 0 then Error_Msg_NE ("cannot find body of generic package &", Inst_Node, Gen_Unit); @@ -8596,6 +8637,14 @@ package body Sem_Ch12 is Expander_Mode_Save_And_Set (Body_Info.Expander_Status); + -- Re-establish the state of information on which checks are suppressed. + -- This information was set in Body_Info at the point of instantiation, + -- and now we restore it so that the instance is compiled using the + -- check status at the instantiation (RM 11.5 (7.2/2), AI95-00224-01). + + Local_Suppress_Stack_Top := Body_Info.Local_Suppress_Stack_Top; + Scope_Suppress := Body_Info.Scope_Suppress; + if No (Gen_Body_Id) then Load_Parent_Of_Generic (Inst_Node, Specification (Gen_Decl)); Gen_Body_Id := Corresponding_Body (Gen_Decl); @@ -8740,9 +8789,7 @@ package body Sem_Ch12 is end if; end if; - if not Generic_Separately_Compiled (Gen_Unit) then - Inherit_Context (Gen_Body, Inst_Node); - end if; + Inherit_Context (Gen_Body, Inst_Node); Restore_Private_Views (Pack_Id, False); @@ -8808,7 +8855,8 @@ package body Sem_Ch12 is Handled_Statement_Sequence => Make_Handled_Sequence_Of_Statements (Loc, Statements => - New_List (Make_Return_Statement (Loc, Ret_Expr)))); + New_List + (Make_Simple_Return_Statement (Loc, Ret_Expr)))); end if; Pack_Body := Make_Package_Body (Loc, @@ -9387,6 +9435,247 @@ package body Sem_Ch12 is Abandon_Instantiation (Actual); end if; end if; + + -- If the formal and actual types are abstract, check that there + -- are no abstract primitives of the actual type that correspond to + -- nonabstract primitives of the formal type (second sentence of + -- RM95-3.9.3(9)). + + if Is_Abstract_Type (A_Gen_T) and then Is_Abstract_Type (Act_T) then + Check_Abstract_Primitives : declare + Gen_Prims : constant Elist_Id := + Primitive_Operations (A_Gen_T); + Gen_Elmt : Elmt_Id; + Gen_Subp : Entity_Id; + Anc_Subp : Entity_Id; + Anc_Formal : Entity_Id; + Anc_F_Type : Entity_Id; + + Act_Prims : constant Elist_Id := Primitive_Operations (Act_T); + Act_Elmt : Elmt_Id; + Act_Subp : Entity_Id; + Act_Formal : Entity_Id; + Act_F_Type : Entity_Id; + + Subprograms_Correspond : Boolean; + + function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean; + -- Returns true if T2 is derived directly or indirectly from + -- T1, including derivations from interfaces. T1 and T2 are + -- required to be specific tagged base types. + + ------------------------ + -- Is_Tagged_Ancestor -- + ------------------------ + + function Is_Tagged_Ancestor (T1, T2 : Entity_Id) return Boolean + is + Interfaces : Elist_Id; + Intfc_Elmt : Elmt_Id; + + begin + -- The predicate is satisfied if the types are the same + + if T1 = T2 then + return True; + + -- If we've reached the top of the derivation chain then + -- we know that T1 is not an ancestor of T2. + + elsif Etype (T2) = T2 then + return False; + + -- Proceed to check T2's immediate parent + + elsif Is_Ancestor (T1, Base_Type (Etype (T2))) then + return True; + + -- Finally, check to see if T1 is an ancestor of any of T2's + -- progenitors. + + else + Interfaces := Abstract_Interfaces (T2); + + Intfc_Elmt := First_Elmt (Interfaces); + while Present (Intfc_Elmt) loop + if Is_Ancestor (T1, Node (Intfc_Elmt)) then + return True; + end if; + + Next_Elmt (Intfc_Elmt); + end loop; + end if; + + return False; + end Is_Tagged_Ancestor; + + -- Start of processing for Check_Abstract_Primitives + + begin + -- Loop over all of the formal derived type's primitives + + Gen_Elmt := First_Elmt (Gen_Prims); + while Present (Gen_Elmt) loop + Gen_Subp := Node (Gen_Elmt); + + -- If the primitive of the formal is not abstract, then + -- determine whether there is a corresponding primitive of + -- the actual type that's abstract. + + if not Is_Abstract_Subprogram (Gen_Subp) then + Act_Elmt := First_Elmt (Act_Prims); + while Present (Act_Elmt) loop + Act_Subp := Node (Act_Elmt); + + -- If we find an abstract primitive of the actual, + -- then we need to test whether it corresponds to the + -- subprogram from which the generic formal primitive + -- is inherited. + + if Is_Abstract_Subprogram (Act_Subp) then + Anc_Subp := Alias (Gen_Subp); + + -- Test whether we have a corresponding primitive + -- by comparing names, kinds, formal types, and + -- result types. + + if Chars (Anc_Subp) = Chars (Act_Subp) + and then Ekind (Anc_Subp) = Ekind (Act_Subp) + then + Anc_Formal := First_Formal (Anc_Subp); + Act_Formal := First_Formal (Act_Subp); + while Present (Anc_Formal) + and then Present (Act_Formal) + loop + Anc_F_Type := Etype (Anc_Formal); + Act_F_Type := Etype (Act_Formal); + + if Ekind (Anc_F_Type) + = E_Anonymous_Access_Type + then + Anc_F_Type := Designated_Type (Anc_F_Type); + + if Ekind (Act_F_Type) + = E_Anonymous_Access_Type + then + Act_F_Type := + Designated_Type (Act_F_Type); + else + exit; + end if; + + elsif + Ekind (Act_F_Type) = E_Anonymous_Access_Type + then + exit; + end if; + + Anc_F_Type := Base_Type (Anc_F_Type); + Act_F_Type := Base_Type (Act_F_Type); + + -- If the formal is controlling, then the + -- the type of the actual primitive's formal + -- must be derived directly or indirectly + -- from the type of the ancestor primitive's + -- formal. + + if Is_Controlling_Formal (Anc_Formal) then + if not Is_Tagged_Ancestor + (Anc_F_Type, Act_F_Type) + then + exit; + end if; + + -- Otherwise the types of the formals must + -- be the same. + + elsif Anc_F_Type /= Act_F_Type then + exit; + end if; + + Next_Entity (Anc_Formal); + Next_Entity (Act_Formal); + end loop; + + -- If we traversed through all of the formals + -- then so far the subprograms correspond, so + -- now check that any result types correspond. + + if No (Anc_Formal) + and then No (Act_Formal) + then + Subprograms_Correspond := True; + + if Ekind (Act_Subp) = E_Function then + Anc_F_Type := Etype (Anc_Subp); + Act_F_Type := Etype (Act_Subp); + + if Ekind (Anc_F_Type) + = E_Anonymous_Access_Type + then + Anc_F_Type := + Designated_Type (Anc_F_Type); + + if Ekind (Act_F_Type) + = E_Anonymous_Access_Type + then + Act_F_Type := + Designated_Type (Act_F_Type); + else + Subprograms_Correspond := False; + end if; + + elsif + Ekind (Act_F_Type) + = E_Anonymous_Access_Type + then + Subprograms_Correspond := False; + end if; + + Anc_F_Type := Base_Type (Anc_F_Type); + Act_F_Type := Base_Type (Act_F_Type); + + -- Now either the result types must be + -- the same or, if the result type is + -- controlling, the result type of the + -- actual primitive must descend from the + -- result type of the ancestor primitive. + + if Subprograms_Correspond + and then Anc_F_Type /= Act_F_Type + and then + Has_Controlling_Result (Anc_Subp) + and then + not Is_Tagged_Ancestor + (Anc_F_Type, Act_F_Type) + then + Subprograms_Correspond := False; + end if; + end if; + + -- Found a matching subprogram belonging to + -- formal ancestor type, so actual subprogram + -- corresponds and this violates 3.9.3(9). + + if Subprograms_Correspond then + Error_Msg_NE + ("abstract subprogram & overrides " & + "nonabstract subprogram of ancestor", + Actual, + Act_Subp); + end if; + end if; + end if; + end if; + + Next_Elmt (Act_Elmt); + end loop; + end if; + + Next_Elmt (Gen_Elmt); + end loop; + end Check_Abstract_Primitives; + end if; end Validate_Derived_Type_Instance; -------------------------------------- @@ -9411,8 +9700,8 @@ package body Sem_Ch12 is Is_Synchronized_Interface (Act_T) then Error_Msg_NE - ("actual for interface& does not match ('R'M 12.5.5(4))", - Actual, Gen_T); + ("actual for interface& does not match (RM 12.5.5(4))", + Actual, Gen_T); end if; end Validate_Interface_Type_Instance; @@ -9636,78 +9925,84 @@ package body Sem_Ch12 is end if; end if; - case Nkind (Def) is - when N_Formal_Private_Type_Definition => - Validate_Private_Type_Instance; + if Error_Posted (Act_T) then + null; + else + case Nkind (Def) is + when N_Formal_Private_Type_Definition => + Validate_Private_Type_Instance; - when N_Formal_Derived_Type_Definition => - Validate_Derived_Type_Instance; + when N_Formal_Derived_Type_Definition => + Validate_Derived_Type_Instance; - when N_Formal_Discrete_Type_Definition => - if not Is_Discrete_Type (Act_T) then - Error_Msg_NE - ("expect discrete type in instantiation of&", Actual, Gen_T); - Abandon_Instantiation (Actual); - end if; + when N_Formal_Discrete_Type_Definition => + if not Is_Discrete_Type (Act_T) then + Error_Msg_NE + ("expect discrete type in instantiation of&", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; - when N_Formal_Signed_Integer_Type_Definition => - if not Is_Signed_Integer_Type (Act_T) then - Error_Msg_NE - ("expect signed integer type in instantiation of&", - Actual, Gen_T); - Abandon_Instantiation (Actual); - end if; + when N_Formal_Signed_Integer_Type_Definition => + if not Is_Signed_Integer_Type (Act_T) then + Error_Msg_NE + ("expect signed integer type in instantiation of&", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; - when N_Formal_Modular_Type_Definition => - if not Is_Modular_Integer_Type (Act_T) then - Error_Msg_NE - ("expect modular type in instantiation of &", Actual, Gen_T); - Abandon_Instantiation (Actual); - end if; + when N_Formal_Modular_Type_Definition => + if not Is_Modular_Integer_Type (Act_T) then + Error_Msg_NE + ("expect modular type in instantiation of &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; - when N_Formal_Floating_Point_Definition => - if not Is_Floating_Point_Type (Act_T) then - Error_Msg_NE - ("expect float type in instantiation of &", Actual, Gen_T); - Abandon_Instantiation (Actual); - end if; + when N_Formal_Floating_Point_Definition => + if not Is_Floating_Point_Type (Act_T) then + Error_Msg_NE + ("expect float type in instantiation of &", Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; - when N_Formal_Ordinary_Fixed_Point_Definition => - if not Is_Ordinary_Fixed_Point_Type (Act_T) then - Error_Msg_NE - ("expect ordinary fixed point type in instantiation of &", - Actual, Gen_T); - Abandon_Instantiation (Actual); - end if; + when N_Formal_Ordinary_Fixed_Point_Definition => + if not Is_Ordinary_Fixed_Point_Type (Act_T) then + Error_Msg_NE + ("expect ordinary fixed point type in instantiation of &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; - when N_Formal_Decimal_Fixed_Point_Definition => - if not Is_Decimal_Fixed_Point_Type (Act_T) then - Error_Msg_NE - ("expect decimal type in instantiation of &", - Actual, Gen_T); - Abandon_Instantiation (Actual); - end if; + when N_Formal_Decimal_Fixed_Point_Definition => + if not Is_Decimal_Fixed_Point_Type (Act_T) then + Error_Msg_NE + ("expect decimal type in instantiation of &", + Actual, Gen_T); + Abandon_Instantiation (Actual); + end if; - when N_Array_Type_Definition => - Validate_Array_Type_Instance; + when N_Array_Type_Definition => + Validate_Array_Type_Instance; - when N_Access_To_Object_Definition => - Validate_Access_Type_Instance; + when N_Access_To_Object_Definition => + Validate_Access_Type_Instance; - when N_Access_Function_Definition | - N_Access_Procedure_Definition => - Validate_Access_Subprogram_Instance; + when N_Access_Function_Definition | + N_Access_Procedure_Definition => + Validate_Access_Subprogram_Instance; - when N_Record_Definition => - Validate_Interface_Type_Instance; + when N_Record_Definition => + Validate_Interface_Type_Instance; - when N_Derived_Type_Definition => - Validate_Derived_Interface_Type_Instance; + when N_Derived_Type_Definition => + Validate_Derived_Interface_Type_Instance; - when others => - raise Program_Error; + when others => + raise Program_Error; - end case; + end case; + end if; Subt := New_Copy (Gen_T); @@ -9736,10 +10031,18 @@ package body Sem_Ch12 is -- appropriate renamings for the primitive operations of the ancestor. -- Flag actual for formal private types as well, to determine whether -- operations in the private part may override inherited operations. + -- If the formal has an interface list, the ancestor is not the + -- parent, but the analyzed formal that includes the interface + -- operations of all its progenitors. - if Nkind (Def) = N_Formal_Derived_Type_Definition - or else Nkind (Def) = N_Formal_Private_Type_Definition - then + if Nkind (Def) = N_Formal_Derived_Type_Definition then + if Present (Interface_List (Def)) then + Set_Generic_Parent_Type (Decl_Node, A_Gen_T); + else + Set_Generic_Parent_Type (Decl_Node, Ancestor); + end if; + + elsif Nkind (Def) = N_Formal_Private_Type_Definition then Set_Generic_Parent_Type (Decl_Node, Ancestor); end if; @@ -9792,7 +10095,6 @@ package body Sem_Ch12 is function Is_Generic_Formal (E : Entity_Id) return Boolean is Kind : Node_Kind; - begin if No (E) then return False; @@ -9852,12 +10154,57 @@ package body Sem_Ch12 is -- Load_Parent_Of_Generic -- ---------------------------- - procedure Load_Parent_Of_Generic (N : Node_Id; Spec : Node_Id) is - Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); - Save_Style_Check : constant Boolean := Style_Check; - True_Parent : Node_Id; - Inst_Node : Node_Id; - OK : Boolean; + procedure Load_Parent_Of_Generic + (N : Node_Id; + Spec : Node_Id; + Body_Optional : Boolean := False) + is + Comp_Unit : constant Node_Id := Cunit (Get_Source_Unit (Spec)); + Save_Style_Check : constant Boolean := Style_Check; + True_Parent : Node_Id; + Inst_Node : Node_Id; + OK : Boolean; + Previous_Instances : constant Elist_Id := New_Elmt_List; + + procedure Collect_Previous_Instances (Decls : List_Id); + -- Collect all instantiations in the given list of declarations, + -- that precedes the generic that we need to load. If the bodies + -- of these instantiations are available, we must analyze them, + -- to ensure that the public symbols generated are the same when + -- the unit is compiled to generate code, and when it is compiled + -- in the context of the unit that needs a particular nested instance. + + -------------------------------- + -- Collect_Previous_Instances -- + -------------------------------- + + procedure Collect_Previous_Instances (Decls : List_Id) is + Decl : Node_Id; + + begin + Decl := First (Decls); + while Present (Decl) loop + if Sloc (Decl) >= Sloc (Inst_Node) then + return; + + elsif Nkind (Decl) = N_Package_Instantiation then + Append_Elmt (Decl, Previous_Instances); + + elsif Nkind (Decl) = N_Package_Declaration then + Collect_Previous_Instances + (Visible_Declarations (Specification (Decl))); + Collect_Previous_Instances + (Private_Declarations (Specification (Decl))); + + elsif Nkind (Decl) = N_Package_Body then + Collect_Previous_Instances (Declarations (Decl)); + end if; + + Next (Decl); + end loop; + end Collect_Previous_Instances; + + -- Start of processing for Load_Parent_Of_Generic begin if not In_Same_Source_Unit (N, Spec) @@ -9875,9 +10222,9 @@ package body Sem_Ch12 is -- in a package body, the instance defined in the same package body, -- and the original enclosing body may not be in the main unit. - True_Parent := Parent (Spec); - Inst_Node := Empty; + Inst_Node := Empty; + True_Parent := Parent (Spec); while Present (True_Parent) and then Nkind (True_Parent) /= N_Compilation_Unit loop @@ -9900,7 +10247,6 @@ package body Sem_Ch12 is -- instantiation node. A direct link would be preferable? Inst_Node := Next (True_Parent); - while Present (Inst_Node) and then Nkind (Inst_Node) /= N_Package_Instantiation loop @@ -9917,6 +10263,7 @@ package body Sem_Ch12 is end if; exit; + else True_Parent := Parent (True_Parent); end if; @@ -9949,8 +10296,8 @@ package body Sem_Ch12 is -- applies. declare - Exp_Status : Boolean := True; - Scop : Entity_Id; + Exp_Status : Boolean := True; + Scop : Entity_Id; begin -- Loop through scopes looking for generic package @@ -9967,10 +10314,73 @@ package body Sem_Ch12 is Scop := Scope (Scop); end loop; + -- Collect previous instantiations in the unit that + -- contains the desired generic, + + if Nkind (Parent (True_Parent)) /= N_Compilation_Unit + and then not Body_Optional + then + declare + Decl : Elmt_Id; + Par : Node_Id; + + begin + Par := Parent (Inst_Node); + while Present (Par) loop + exit when Nkind (Parent (Par)) = N_Compilation_Unit; + Par := Parent (Par); + end loop; + + pragma Assert (Present (Par)); + + if Nkind (Par) = N_Package_Body then + Collect_Previous_Instances (Declarations (Par)); + + elsif Nkind (Par) = N_Package_Declaration then + Collect_Previous_Instances + (Visible_Declarations (Specification (Par))); + Collect_Previous_Instances + (Private_Declarations (Specification (Par))); + + else + -- Enclosing unit is a subprogram body, In this + -- case all instance bodies are processed in order + -- and there is no need to collect them separately. + + null; + end if; + + Decl := First_Elmt (Previous_Instances); + while Present (Decl) loop + Instantiate_Package_Body + (Body_Info => + ((Inst_Node => Node (Decl), + Act_Decl => + Instance_Spec (Node (Decl)), + Expander_Status => Exp_Status, + Current_Sem_Unit => + Get_Code_Unit (Sloc (Node (Decl))), + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => + Local_Suppress_Stack_Top)), + Body_Optional => True); + + Next_Elmt (Decl); + end loop; + end; + end if; + Instantiate_Package_Body - (Pending_Body_Info'( - Inst_Node, True_Parent, Exp_Status, - Get_Code_Unit (Sloc (Inst_Node)))); + (Body_Info => + ((Inst_Node => Inst_Node, + Act_Decl => True_Parent, + Expander_Status => Exp_Status, + Current_Sem_Unit => + Get_Code_Unit (Sloc (Inst_Node)), + Scope_Suppress => Scope_Suppress, + Local_Suppress_Stack_Top => + Local_Suppress_Stack_Top)), + Body_Optional => Body_Optional); end; end if; @@ -9985,6 +10395,7 @@ package body Sem_Ch12 is if not OK and then Unit_Requires_Body (Defining_Entity (Spec)) + and then not Body_Optional then declare Bname : constant Unit_Name_Type := @@ -10619,8 +11030,8 @@ package body Sem_Ch12 is procedure Reset_Entity (N : Node_Id) is procedure Set_Global_Type (N : Node_Id; N2 : Node_Id); - -- The type of N2 is global to the generic unit. Save the - -- type in the generic node. + -- If the type of N2 is global to the generic unit. Save + -- the type in the generic node. function Top_Ancestor (E : Entity_Id) return Entity_Id; -- Find the ultimate ancestor of the current unit. If it is @@ -10766,15 +11177,22 @@ package body Sem_Ch12 is end if; -- A selected component may denote a static constant that has been - -- folded. Make the same replacement in original tree. + -- folded. If the static constant is global to the generic, capture + -- its value. Otherwise the folding will happen in any instantiation, elsif Nkind (Parent (N)) = N_Selected_Component and then (Nkind (Parent (N2)) = N_Integer_Literal or else Nkind (Parent (N2)) = N_Real_Literal) then - Rewrite (Parent (N), - New_Copy (Parent (N2))); - Set_Analyzed (Parent (N), False); + if Present (Entity (Original_Node (Parent (N2)))) + and then Is_Global (Entity (Original_Node (Parent (N2)))) + then + Rewrite (Parent (N), New_Copy (Parent (N2))); + Set_Analyzed (Parent (N), False); + + else + null; + end if; -- A selected component may be transformed into a parameterless -- function call. If the called entity is global, rewrite the node @@ -11377,11 +11795,10 @@ package body Sem_Ch12 is procedure Start_Generic is begin - -- ??? I am sure more things could be factored out in this routine. + -- ??? More things could be factored out in this routine. -- Should probably be done at a later stage. - Generic_Flags.Increment_Last; - Generic_Flags.Table (Generic_Flags.Last) := Inside_A_Generic; + Generic_Flags.Append (Inside_A_Generic); Inside_A_Generic := True; Expander_Mode_Save_And_Set (False); @@ -11398,13 +11815,15 @@ package body Sem_Ch12 is begin -- Regardless of the current mode, predefined units are analyzed in -- the most current Ada mode, and earlier version Ada checks do not - -- apply to predefined units. + -- apply to predefined units. Nothing needs to be done for non-internal + -- units. These are always analyzed in the current mode. - Set_Opt_Config_Switches ( - Is_Internal_File_Name + if Is_Internal_File_Name (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), - Renamings_Included => True), - Current_Sem_Unit = Main_Unit); + Renamings_Included => True) + then + Set_Opt_Config_Switches (True, Current_Sem_Unit = Main_Unit); + end if; Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null); end Set_Instance_Env; diff --git a/gcc/ada/sem_ch12.ads b/gcc/ada/sem_ch12.ads index 2c32536..831e480 100644 --- a/gcc/ada/sem_ch12.ads +++ b/gcc/ada/sem_ch12.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2007, 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- -- @@ -58,8 +58,7 @@ package Sem_Ch12 is function Copy_Generic_Node (N : Node_Id; Parent_Id : Node_Id; - Instantiating : Boolean) - return Node_Id; + Instantiating : Boolean) return Node_Id; -- Copy the tree for a generic unit or its body. The unit is copied -- repeatedly: once to produce a copy on which semantic analysis of -- the generic is performed, and once for each instantiation. The tree @@ -76,11 +75,30 @@ package Sem_Ch12 is -- of the ancestors of a child generic that is being instantiated. procedure Instantiate_Package_Body - (Body_Info : Pending_Body_Info; - Inlined_Body : Boolean := False); + (Body_Info : Pending_Body_Info; + Inlined_Body : Boolean := False; + Body_Optional : Boolean := False); -- Called after semantic analysis, to complete the instantiation of -- package instances. The flag Inlined_Body is set if the body is -- being instantiated on the fly for inlined purposes. + -- + -- The flag Body_Optional indicates that the call is for an instance + -- that precedes the current instance in the same declarative part. + -- This call is needed when instantiating a nested generic whose body + -- is to be found in the body of an instance. Normally we instantiate + -- package bodies only when they appear in the main unit, or when their + -- contents are needed for a nested generic G. If unit U contains several + -- instances I1, I2, etc. and I2 contains a nested generic, then when U + -- appears in the context of some other unit P that contains an instance + -- of G, we compile the body of I2, but not that of I1. However, when we + -- compile U as the main unit, we compile both bodies. This will lead to + -- lead to link-time errors if the compilation of I1 generates public + -- symbols, because those in I2 will receive different names in both + -- cases. This forces us to analyze the body of I1 even when U is not the + -- main unit. We don't want this additional mechanism to generate an error + -- when the body of the generic for I1 is not present, and this is the + -- reason for the presence of the flag Body_Optional, which is exchanged + -- between the current procedure and Load_Parent_Of_Generic. procedure Instantiate_Subprogram_Body (Body_Info : Pending_Body_Info); |