X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_ch8.adb;h=dda30af7e1c810a159871f763deac21ee02b8c07;hb=c0a208a52ba10b65d217c635ddddf7a07ea51ebd;hp=5a782f3c20cc07db36803754fb452931cc885af0;hpb=a053db0dacfa6b670bc8f8e3f9dff1f24159db77;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 5a782f3c20c..dda30af7e1c 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2011, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2012, 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- -- @@ -52,6 +52,8 @@ with Sem_Ch3; use Sem_Ch3; with Sem_Ch4; use Sem_Ch4; with Sem_Ch6; use Sem_Ch6; with Sem_Ch12; use Sem_Ch12; +with Sem_Ch13; use Sem_Ch13; +with Sem_Dim; use Sem_Dim; with Sem_Disp; use Sem_Disp; with Sem_Dist; use Sem_Dist; with Sem_Eval; use Sem_Eval; @@ -802,8 +804,13 @@ package body Sem_Ch8 is T := Entity (Subtype_Mark (N)); Analyze (Nam); + -- Reject renamings of conversions unless the type is tagged, or + -- the conversion is implicit (which can occur for cases of anonymous + -- access types in Ada 2012). + if Nkind (Nam) = N_Type_Conversion - and then not Is_Tagged_Type (T) + and then Comes_From_Source (Nam) + and then not Is_Tagged_Type (T) then Error_Msg_N ("renaming of conversion only allowed for tagged types", Nam); @@ -834,6 +841,22 @@ package body Sem_Ch8 is return; end if; + -- Ada 2012 (AI05-149): Reject renaming of an anonymous access object + -- when renaming declaration has a named access type. The Ada 2012 + -- coverage rules allow an anonymous access type in the context of + -- an expected named general access type, but the renaming rules + -- require the types to be the same. (An exception is when the type + -- of the renaming is also an anonymous access type, which can only + -- happen due to a renaming created by the expander.) + + if Nkind (Nam) = N_Type_Conversion + and then not Comes_From_Source (Nam) + and then Ekind (Etype (Expression (Nam))) = E_Anonymous_Access_Type + and then Ekind (T) /= E_Anonymous_Access_Type + then + Wrong_Type (Expression (Nam), T); -- Should we give better error??? + end if; + -- Check that a class-wide object is not being renamed as an object -- of a specific type. The test for access types is needed to exclude -- cases where the renamed object is a dynamically tagged access @@ -1116,7 +1139,12 @@ package body Sem_Ch8 is end if; Set_Ekind (Id, E_Variable); - Init_Size_Align (Id); + + -- Initialize the object size and alignment. Note that we used to call + -- Init_Size_Align here, but that's wrong for objects which have only + -- an Esize, not an RM_Size field! + + Init_Object_Size_Align (Id); if T = Any_Type or else Etype (Nam) = Any_Type then return; @@ -1188,6 +1216,7 @@ package body Sem_Ch8 is end if; Set_Renamed_Object (Id, Nam); + Analyze_Dimension (N); end Analyze_Object_Renaming; ------------------------------ @@ -1634,11 +1663,6 @@ package body Sem_Ch8 is procedure Analyze_Subprogram_Renaming (N : Node_Id) is Formal_Spec : constant Node_Id := Corresponding_Formal_Spec (N); Is_Actual : constant Boolean := Present (Formal_Spec); - - CW_Actual : Boolean := False; - -- True if the renaming is for a defaulted formal subprogram when the - -- actual for a related formal type is class-wide. For AI05-0071. - Inst_Node : Node_Id := Empty; Nam : constant Node_Id := Name (N); New_S : Entity_Id; @@ -1691,6 +1715,11 @@ package body Sem_Ch8 is -- This rule only applies if there is no explicit visible class-wide -- operation at the point of the instantiation. + function Has_Class_Wide_Actual return Boolean; + -- Ada 2012 (AI05-071, AI05-0131): True if N is the renaming for a + -- defaulted formal subprogram when the actual for the controlling + -- formal type is class-wide. + ----------------------------- -- Check_Class_Wide_Actual -- ----------------------------- @@ -1729,7 +1758,7 @@ package body Sem_Ch8 is Next (F); end loop; - if Ekind (Prim_Op) = E_Function then + if Ekind_In (Prim_Op, E_Function, E_Operator) then return Make_Simple_Return_Statement (Loc, Expression => Make_Function_Call (Loc, @@ -1780,6 +1809,7 @@ package body Sem_Ch8 is F := First_Formal (Formal_Spec); while Present (F) loop if Has_Unknown_Discriminants (Etype (F)) + and then not Is_Class_Wide_Type (Etype (F)) and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F))) then Formal_Type := Etype (F); @@ -1791,7 +1821,6 @@ package body Sem_Ch8 is end loop; if Present (Formal_Type) then - CW_Actual := True; -- Create declaration and body for class-wide operation @@ -1833,9 +1862,12 @@ package body Sem_Ch8 is Statements (Handled_Statement_Sequence (New_Body))); -- The generated body does not freeze. It is analyzed when the - -- generated operation is frozen. + -- generated operation is frozen. This body is only needed if + -- expansion is enabled. - Append_Freeze_Action (Defining_Entity (New_Decl), New_Body); + if Expander_Active then + Append_Freeze_Action (Defining_Entity (New_Decl), New_Body); + end if; Result := Defining_Entity (New_Decl); end if; @@ -1893,6 +1925,41 @@ package body Sem_Ch8 is end if; end Check_Null_Exclusion; + --------------------------- + -- Has_Class_Wide_Actual -- + --------------------------- + + function Has_Class_Wide_Actual return Boolean is + F_Nam : Entity_Id; + F_Spec : Entity_Id; + + begin + if Is_Actual + and then Nkind (Nam) in N_Has_Entity + and then Present (Entity (Nam)) + and then Is_Dispatching_Operation (Entity (Nam)) + then + F_Nam := First_Entity (Entity (Nam)); + F_Spec := First_Formal (Formal_Spec); + while Present (F_Nam) + and then Present (F_Spec) + loop + if Is_Controlling_Formal (F_Nam) + and then Has_Unknown_Discriminants (Etype (F_Spec)) + and then not Is_Class_Wide_Type (Etype (F_Spec)) + and then Is_Class_Wide_Type (Get_Instance_Of (Etype (F_Spec))) + then + return True; + end if; + + Next_Entity (F_Nam); + Next_Formal (F_Spec); + end loop; + end if; + + return False; + end Has_Class_Wide_Actual; + ------------------------- -- Original_Subprogram -- ------------------------- @@ -1938,6 +2005,11 @@ package body Sem_Ch8 is end if; end Original_Subprogram; + CW_Actual : constant Boolean := Has_Class_Wide_Actual; + -- Ada 2012 (AI05-071, AI05-0131): True if the renaming is for a + -- defaulted formal subprogram when the actual for a related formal + -- type is class-wide. + -- Start of processing for Analyze_Subprogram_Renaming begin @@ -1956,7 +2028,7 @@ package body Sem_Ch8 is -- expanded in subsequent instantiations. if Is_Actual and then Is_Abstract_Subprogram (Formal_Spec) - and then Expander_Active + and then Full_Expander_Active then declare Stream_Prim : Entity_Id; @@ -2058,7 +2130,14 @@ package body Sem_Ch8 is if Is_Actual then Inst_Node := Unit_Declaration_Node (Formal_Spec); - if Is_Entity_Name (Nam) + -- Check whether the renaming is for a defaulted actual subprogram + -- with a class-wide actual. + + if CW_Actual then + New_S := Analyze_Subprogram_Specification (Spec); + Old_S := Check_Class_Wide_Actual; + + elsif Is_Entity_Name (Nam) and then Present (Entity (Nam)) and then not Comes_From_Source (Nam) and then not Is_Overloaded (Nam) @@ -2322,7 +2401,14 @@ package body Sem_Ch8 is elsif not Is_Entity_Name (Nam) or else not Is_Overloadable (Entity (Nam)) then - Error_Msg_N ("expect valid subprogram name in renaming", N); + -- Do not mention the renaming if it comes from an instance + + if not Is_Actual then + Error_Msg_N ("expect valid subprogram name in renaming", N); + else + Error_Msg_NE ("no visible subprogram for formal&", N, Nam); + end if; + return; end if; @@ -2419,16 +2505,6 @@ package body Sem_Ch8 is end if; end if; - -- If no renamed entity was found, check whether the renaming is for - -- a defaulted actual subprogram with a class-wide actual. - - if Old_S = Any_Id - and then Is_Actual - and then From_Default (N) - then - Old_S := Check_Class_Wide_Actual; - end if; - if Old_S /= Any_Id then if Is_Actual and then From_Default (N) then @@ -2588,8 +2664,14 @@ package body Sem_Ch8 is if not Is_Actual and then (Old_S = New_S - or else (Nkind (Nam) /= N_Expanded_Name - and then Chars (Old_S) = Chars (New_S))) + or else + (Nkind (Nam) /= N_Expanded_Name + and then Chars (Old_S) = Chars (New_S)) + or else + (Nkind (Nam) = N_Expanded_Name + and then Entity (Prefix (Nam)) = Current_Scope + and then + Chars (Selector_Name (Nam)) = Chars (New_S))) then Error_Msg_N ("subprogram cannot rename itself", N); end if; @@ -2775,6 +2857,14 @@ package body Sem_Ch8 is ("?redundant renaming, entity is directly visible", Name (N)); end if; + -- Implementation-defined aspect specifications can appear in a renaming + -- declaration, but not language-defined ones. The call to procedure + -- Analyze_Aspect_Specifications will take care of this error check. + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, New_S); + end if; + Ada_Version := Save_AV; Ada_Version_Explicit := Save_AV_Exp; end Analyze_Subprogram_Renaming; @@ -3227,10 +3317,15 @@ package body Sem_Ch8 is -- type is still not frozen). We exclude from this processing generic -- formal subprograms found in instantiations and AST_Entry renamings. - -- We must exclude VM targets because entity AST_Handler is defined in - -- package System.Aux_Dec which is not available in those platforms. + -- We must exclude VM targets and restricted run-time libraries because + -- entity AST_Handler is defined in package System.Aux_Dec which is not + -- available in those platforms. Note that we cannot use the function + -- Restricted_Profile (instead of Configurable_Run_Time_Mode) because + -- the ZFP run-time library is not defined as a profile, and we do not + -- want to deal with AST_Handler in ZFP mode. if VM_Target = No_VM + and then not Configurable_Run_Time_Mode and then not Present (Corresponding_Formal_Spec (N)) and then Etype (Nam) /= RTE (RE_AST_Handler) then @@ -6030,10 +6125,16 @@ package body Sem_Ch8 is -- is completed in the current scope, and not for a limited -- view of a type. - if not Is_Tagged_Type (T) - and then Ada_Version >= Ada_2005 - then - if From_With_Type (T) then + if Ada_Version >= Ada_2005 then + + -- Test whether the Available_View of a limited type view + -- is tagged, since the limited view may not be marked as + -- tagged if the type itself has an untagged incomplete + -- type view in its package. + + if From_With_Type (T) + and then not Is_Tagged_Type (Available_View (T)) + then Error_Msg_N ("prefix of Class attribute must be tagged", N); Set_Etype (N, Any_Type); @@ -7936,7 +8037,7 @@ package body Sem_Ch8 is end if; end Use_Class_Wide_Operations; - -- Start of processing for Use_One_Type; + -- Start of processing for Use_One_Type begin -- It is the type determined by the subtype mark (8.4(8)) whose