X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch12.adb;h=9449c607f5b90fdb2521f2f6be14984034513103;hb=735f4358c84bd478ae8c4b635a4d938447867efe;hp=babcc70eda63823bf3765b8a11bc860aa9e8a39e;hpb=ea61a7eac2bd83ab4f8831935cc59f90ea601eb3;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index babcc70eda6..9449c607f5b 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2003, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2004, 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- -- @@ -40,6 +40,7 @@ with Lib.Xref; use Lib.Xref; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; +with Rident; use Rident; with Restrict; use Restrict; with Rtsfind; use Rtsfind; with Sem; use Sem; @@ -673,7 +674,7 @@ package body Sem_Ch12 is -- generic is unit is validated, Set_Instance_Env completes Save_Env. type Instance_Env is record - Ada_83 : Boolean; + Ada_Version : Ada_Version_Type; Instantiated_Parent : Assoc; Exchanged_Views : Elist_Id; Hidden_Entities : Elist_Id; @@ -987,6 +988,7 @@ package body Sem_Ch12 is Defining_Identifier (Analyzed_Formal)); if No (Match) then + Error_Msg_Sloc := Sloc (Gen_Unit); Error_Msg_NE ("missing actual&", Instantiation_Node, Defining_Identifier (Formal)); @@ -1075,6 +1077,7 @@ package body Sem_Ch12 is Defining_Identifier (Original_Node (Analyzed_Formal))); if No (Match) then + Error_Msg_Sloc := Sloc (Gen_Unit); Error_Msg_NE ("missing actual&", Instantiation_Node, Defining_Identifier (Formal)); @@ -1111,6 +1114,8 @@ package body Sem_Ch12 is end loop; if Num_Actuals > Num_Matched then + Error_Msg_Sloc := Sloc (Gen_Unit); + if Present (Selector_Name (Actual)) then Error_Msg_NE ("unmatched actual&", @@ -1210,12 +1215,13 @@ package body Sem_Ch12 is Error_Msg_N ("premature usage of incomplete type", Def); elsif Is_Internal (Component_Type (T)) - and then Nkind (Original_Node (Subtype_Indication (Def))) + and then Nkind (Original_Node + (Subtype_Indication (Component_Definition (Def)))) /= N_Attribute_Reference then Error_Msg_N ("only a subtype mark is allowed in a formal", - Subtype_Indication (Def)); + Subtype_Indication (Component_Definition (Def))); end if; end Analyze_Formal_Array_Type; @@ -1462,7 +1468,10 @@ package body Sem_Ch12 is end if; if K = E_Generic_In_Parameter then - if Is_Limited_Type (T) then + + -- Ada 2005 (AI-287): Limited aggregates allowed in generic formals + + if Ada_Version < Ada_05 and then Is_Limited_Type (T) then Error_Msg_N ("generic formal of mode IN must not be of limited type", N); Explain_Limited_Type (T, N); @@ -1569,7 +1578,8 @@ package body Sem_Ch12 is procedure Analyze_Formal_Package (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); - Formal : constant Entity_Id := Defining_Identifier (N); + Pack_Id : constant Entity_Id := Defining_Identifier (N); + Formal : Entity_Id; Gen_Id : constant Node_Id := Name (N); Gen_Decl : Node_Id; Gen_Unit : Entity_Id; @@ -1597,6 +1607,27 @@ package body Sem_Ch12 is Gen_Id); Restore_Env; return; + + elsif In_Open_Scopes (Gen_Unit) then + if Is_Compilation_Unit (Gen_Unit) + and then Is_Child_Unit (Current_Scope) + then + -- Special-case the error when the formal is a parent, and + -- continue analysis to minimize cascaded errors. + + Error_Msg_N + ("generic parent cannot be used as formal package " + & "of a child unit", + Gen_Id); + + else + Error_Msg_N + ("generic package cannot be used as a formal package " + & "within itself", + Gen_Id); + Restore_Env; + return; + end if; end if; -- Check for a formal package that is a package renaming. @@ -1623,8 +1654,6 @@ package body Sem_Ch12 is -- and analyze it like a regular package, except that we treat the -- formals as additional visible components. - Set_Instance_Env (Gen_Unit, Formal); - Gen_Decl := Unit_Declaration_Node (Gen_Unit); if In_Extended_Main_Source_Unit (N) then @@ -1632,11 +1661,13 @@ package body Sem_Ch12 is Generate_Reference (Gen_Unit, N); end if; + Formal := New_Copy (Pack_Id); New_N := Copy_Generic_Node (Original_Node (Gen_Decl), Empty, Instantiating => True); - Set_Defining_Unit_Name (Specification (New_N), Formal); Rewrite (N, New_N); + Set_Defining_Unit_Name (Specification (New_N), Formal); + Set_Instance_Env (Gen_Unit, Formal); Enter_Name (Formal); Set_Ekind (Formal, E_Generic_Package); @@ -1698,6 +1729,11 @@ package body Sem_Ch12 is Set_Ekind (Formal, E_Package); Set_Generic_Parent (Specification (N), Gen_Unit); Set_Has_Completion (Formal, True); + + Set_Ekind (Pack_Id, E_Package); + Set_Etype (Pack_Id, Standard_Void_Type); + Set_Scope (Pack_Id, Scope (Formal)); + Set_Has_Completion (Pack_Id, True); end if; end Analyze_Formal_Package; @@ -2348,6 +2384,8 @@ package body Sem_Ch12 is elsif Ekind (Gen_Unit) /= E_Generic_Package then + -- Ada 2005 (AI-50217): Cannot use instance in limited with_clause + if From_With_Type (Gen_Unit) then Error_Msg_N ("cannot instantiate a limited withed package", Gen_Id); @@ -2568,7 +2606,7 @@ package body Sem_Ch12 is if In_Open_Scopes (Scope (Scope (Gen_Unit))) then declare - Decl : Node_Id := + Decl : constant Node_Id := Original_Node (Unit_Declaration_Node (Scope (Gen_Unit))); begin @@ -3598,6 +3636,21 @@ package body Sem_Ch12 is -- Common error routine for mismatch between the parameters of -- the actual instance and those of the formal package. + function Same_Instantiated_Constant (E1, E2 : Entity_Id) return Boolean; + -- The formal may come from a nested formal package, and the actual + -- may have been constant-folded. To determine whether the two denote + -- the same entity we may have to traverse several definitions to + -- recover the ultimate entity that they refer to. + + function Same_Instantiated_Variable (E1, E2 : Entity_Id) return Boolean; + -- Similarly, if the formal comes from a nested formal package, the + -- actual may designate the formal through multiple renamings, which + -- have to be followed to determine the original variable in question. + + -------------------- + -- Check_Mismatch -- + -------------------- + procedure Check_Mismatch (B : Boolean) is begin if B then @@ -3607,6 +3660,79 @@ package body Sem_Ch12 is end if; end Check_Mismatch; + -------------------------------- + -- Same_Instantiated_Constant -- + -------------------------------- + + function Same_Instantiated_Constant + (E1, E2 : Entity_Id) return Boolean + is + Ent : Entity_Id; + begin + Ent := E2; + while Present (Ent) loop + if E1 = Ent then + return True; + + elsif Ekind (Ent) /= E_Constant then + return False; + + elsif Is_Entity_Name (Constant_Value (Ent)) then + if Entity (Constant_Value (Ent)) = E1 then + return True; + else + Ent := Entity (Constant_Value (Ent)); + end if; + + -- The actual may be a constant that has been folded. Recover + -- original name. + + elsif Is_Entity_Name (Original_Node (Constant_Value (Ent))) then + Ent := Entity (Original_Node (Constant_Value (Ent))); + else + return False; + end if; + end loop; + + return False; + end Same_Instantiated_Constant; + + -------------------------------- + -- Same_Instantiated_Variable -- + -------------------------------- + + function Same_Instantiated_Variable + (E1, E2 : Entity_Id) return Boolean + is + function Original_Entity (E : Entity_Id) return Entity_Id; + -- Follow chain of renamings to the ultimate ancestor. + + --------------------- + -- Original_Entity -- + --------------------- + + function Original_Entity (E : Entity_Id) return Entity_Id is + Orig : Entity_Id; + + begin + Orig := E; + while Nkind (Parent (Orig)) = N_Object_Renaming_Declaration + and then Present (Renamed_Object (Orig)) + and then Is_Entity_Name (Renamed_Object (Orig)) + loop + Orig := Entity (Renamed_Object (Orig)); + end loop; + + return Orig; + end Original_Entity; + + -- Start of processing for Same_Instantiated_Variable + + begin + return Ekind (E1) = Ekind (E2) + and then Original_Entity (E1) = Original_Entity (E2); + end Same_Instantiated_Variable; + -- Start of processing for Check_Formal_Package_Instance begin @@ -3684,20 +3810,23 @@ package body Sem_Ch12 is if Is_Entity_Name (Expr2) then if Entity (Expr1) = Entity (Expr2) then null; - - elsif Ekind (Entity (Expr2)) = E_Constant - and then Is_Entity_Name (Constant_Value (Entity (Expr2))) - and then - Entity (Constant_Value (Entity (Expr2))) = Entity (Expr1) - then - null; else - Check_Mismatch (True); + Check_Mismatch + (not Same_Instantiated_Constant + (Entity (Expr1), Entity (Expr2))); end if; else Check_Mismatch (True); end if; + elsif Is_Entity_Name (Original_Node (Expr1)) + and then Is_Entity_Name (Expr2) + and then + Same_Instantiated_Constant + (Entity (Original_Node (Expr1)), Entity (Expr2)) + then + null; + elsif Nkind (Expr1) = N_Null then Check_Mismatch (Nkind (Expr1) /= N_Null); @@ -3705,9 +3834,10 @@ package body Sem_Ch12 is Check_Mismatch (True); end if; - elsif Ekind (E1) = E_Variable - or else Ekind (E1) = E_Package - then + elsif Ekind (E1) = E_Variable then + Check_Mismatch (not Same_Instantiated_Variable (E1, E2)); + + elsif Ekind (E1) = E_Package then Check_Mismatch (Ekind (E1) /= Ekind (E2) or else Renamed_Object (E1) /= Renamed_Object (E2)); @@ -5544,7 +5674,7 @@ package body Sem_Ch12 is Saved : Instance_Env; begin - Saved.Ada_83 := Ada_83; + Saved.Ada_Version := Ada_Version; Saved.Instantiated_Parent := Current_Instantiated_Parent; Saved.Exchanged_Views := Exchanged_Views; Saved.Hidden_Entities := Hidden_Entities; @@ -6122,8 +6252,7 @@ package body Sem_Ch12 is end loop; when others => - null; - pragma Assert (False); + raise Program_Error; end case; end Find_Matching_Actual; @@ -6239,7 +6368,7 @@ package body Sem_Ch12 is Gen_Anc : Entity_Id) return Boolean is - Gen_Par : Entity_Id := Generic_Parent (Act_Spec); + Gen_Par : constant Entity_Id := Generic_Parent (Act_Spec); begin if No (Gen_Par) then @@ -6439,9 +6568,11 @@ package body Sem_Ch12 is Next_Non_Pragma (Formal_Node); else - -- No further formals to match. + -- No further formals to match, but the generic + -- part may contain inherited operation that are + -- not hidden in the enclosing instance. - exit; + Next_Entity (Actual_Ent); end if; end loop; @@ -6620,6 +6751,7 @@ package body Sem_Ch12 is end if; else + Error_Msg_Sloc := Sloc (Scope (Analyzed_S)); Error_Msg_NE ("missing actual&", Instantiation_Node, Formal_Sub); Error_Msg_NE @@ -6631,7 +6763,14 @@ package body Sem_Ch12 is Decl_Node := Make_Subprogram_Renaming_Declaration (Loc, Specification => New_Spec, - Name => Nam); + Name => Nam); + + -- If we do not have an actual and the formal specified <> then + -- set to get proper default. + + if No (Actual) and then Box_Present (Formal) then + Set_From_Default (Decl_Node); + end if; -- Gather possible interpretations for the actual before analyzing the -- instance. If overloaded, it will be resolved when analyzing the @@ -6746,6 +6885,9 @@ package body Sem_Ch12 is Subt_Decl : Node_Id := Empty; begin + -- Sloc for error message on missing actual. + Error_Msg_Sloc := Sloc (Scope (Defining_Identifier (Analyzed_Formal))); + if Get_Instance_Of (Formal_Id) /= Formal_Id then Error_Msg_N ("duplicate instantiation of generic parameter", Actual); end if; @@ -7250,7 +7392,15 @@ package body Sem_Ch12 is if Nkind (Gen_Body) = N_Subprogram_Body_Stub then -- Either body is not present, or context is non-expanding, as - -- when compiling a subunit. Mark the instance as completed. + -- when compiling a subunit. Mark the instance as completed, and + -- diagnose a missing body when needed. + + if Expander_Active + and then Operating_Mode = Generate_Code + then + Error_Msg_N + ("missing proper body for instantiation", Gen_Body); + end if; Set_Has_Completion (Anon_Id); return; @@ -7755,8 +7905,7 @@ package body Sem_Ch12 is begin Decl := First (Actual_Decls); - - while (Present (Decl)) loop + while Present (Decl) loop if Nkind (Decl) = N_Subtype_Declaration and then Chars (Defining_Identifier (Decl)) = Chars (Etype (A_Gen_T)) @@ -7851,6 +8000,7 @@ package body Sem_Ch12 is -- actual must correspond to a discriminant of the formal. elsif Has_Discriminants (Act_T) + and then not Has_Unknown_Discriminants (Act_T) and then Has_Discriminants (Ancestor) then Actual_Discr := First_Discriminant (Act_T); @@ -7882,7 +8032,9 @@ package body Sem_Ch12 is -- for constrainedness, but the check here is added for -- completeness. - elsif Has_Discriminants (Act_T) then + elsif Has_Discriminants (Act_T) + and then not Has_Unknown_Discriminants (Act_T) + then Error_Msg_NE ("actual for & must not have discriminants", Actual, Gen_T); Abandon_Instantiation (Actual); @@ -7922,7 +8074,7 @@ package body Sem_Ch12 is elsif Is_Indefinite_Subtype (Act_T) and then not Is_Indefinite_Subtype (A_Gen_T) - and then Ada_95 + and then Ada_Version >= Ada_95 then Error_Msg_NE ("actual for & must be a definite subtype", Actual, Gen_T); @@ -7978,7 +8130,7 @@ package body Sem_Ch12 is elsif not Subtypes_Statically_Match (Formal_Subt, Etype (Actual_Discr)) - and then Ada_95 + and then Ada_Version >= Ada_95 then Error_Msg_NE ("subtypes of actual discriminants must match formal", @@ -8599,6 +8751,10 @@ package body Sem_Ch12 is Set_In_Private_Part (P); end if; + -- This looks incomplete: what about compilation units that + -- were made visible by Install_Parent but should not remain + -- visible??? Standard is on the scope stack. + elsif not In_Open_Scopes (Scope (P)) then Set_Is_Immediately_Visible (P, False); end if; @@ -8637,7 +8793,7 @@ package body Sem_Ch12 is Saved : Instance_Env renames Instance_Envs.Table (Instance_Envs.Last); begin - Ada_83 := Saved.Ada_83; + Ada_Version := Saved.Ada_Version; if No (Current_Instantiated_Parent.Act_Id) then @@ -9377,7 +9533,6 @@ package body Sem_Ch12 is -- inlining. Rewrite (N, New_Copy (N2)); - Set_Associated_Node (N, N2); Set_Analyzed (N, False); end if; end if; @@ -9597,12 +9752,13 @@ package body Sem_Ch12 is begin -- Regardless of the current mode, predefined units are analyzed in - -- Ada95 mode, and Ada83 checks don't apply. + -- the most current Ada mode, and earlier version Ada checks do not + -- apply to predefined units. if Is_Internal_File_Name (Fname => Unit_File_Name (Get_Source_Unit (Gen_Unit)), Renamings_Included => True) then - Ada_83 := False; + Ada_Version := Ada_Version_Type'Last; end if; Current_Instantiated_Parent := (Gen_Unit, Act_Unit, Assoc_Null);