From: Javier Miranda Date: Wed, 6 Jun 2007 10:42:51 +0000 (+0200) Subject: sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the use of entity... X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=8909e1edc6c67c2946ebf4d2581edd7126e6aa12;p=gcc.git sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the use of entity Exception_Occurrence if... 2007-04-20 Javier Miranda Hristian Kirtchev Gary Dismukes * sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the use of entity Exception_Occurrence if it is not available in the target run-time. * sem_ch9.adb (Analyze_Protected_Type, Analyze_Task_Type): When concurrent types are declared within an Ada 2005 generic, build their corresponding record types since they are needed for overriding-related semantic checks. (Analyze_Protected_Type): Rearrange and simplify code for testing that a protected type does not implement a task interface or a nonlimited interface. (Analyze_Task_Type): Rearrange and simplify code for testing that a task type does not implement a protected interface or a nonlimited interface. (Single_Task_Declaration, Single_Protected_Declaration): use original entity for variable declaration, to ensure that debugging information is correcty generated. (Analyze_Protected_Type, Analyze_Task_Type): Do not call expander routines if the expander is not active. (Analyze_Task_Body): Mark all handlers to stop optimization of local raise, since special things happen for task exception handlers. * sem_disp.adb (Check_Controlling_Formals): Add type retrieval for concurrent types declared within a generic. (Check_Dispatching_Operation): Do not emit warning about late interface operations in the context of an instance. (Check_Dispatching_Call): Remove restriction against calling a dispatching operation with a limited controlling result. (Check_Dispatching_Operation): Replace calls to Fill_DT_Entry and Register_Interface_DT_Entry by calls to Register_Primitive. (Check_Dispatching_Formals): Handle properly a function with a controlling access result. From-SVN: r125448 --- diff --git a/gcc/ada/sem_ch11.adb b/gcc/ada/sem_ch11.adb index 0f2245e33f8..10916febfca 100644 --- a/gcc/ada/sem_ch11.adb +++ b/gcc/ada/sem_ch11.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -30,6 +30,7 @@ with Einfo; use Einfo; with Errout; use Errout; with Lib; use Lib; with Lib.Xref; use Lib.Xref; +with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -203,7 +204,7 @@ package body Sem_Ch11 is (E_Block, Current_Scope, Sloc (Choice), 'E'); end if; - New_Scope (H_Scope); + Push_Scope (H_Scope); Set_Etype (H_Scope, Standard_Void_Type); -- Set the Finalization Chain entity to Error means that it @@ -217,7 +218,11 @@ package body Sem_Ch11 is Enter_Name (Choice); Set_Ekind (Choice, E_Variable); - Set_Etype (Choice, RTE (RE_Exception_Occurrence)); + + if RTE_Available (RE_Exception_Occurrence) then + Set_Etype (Choice, RTE (RE_Exception_Occurrence)); + end if; + Generate_Definition (Choice); -- Set source assigned flag, since in effect this field is diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index e42dbe9d8d9..65d0e8206ce 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -33,6 +33,7 @@ with Elists; use Elists; with Freeze; use Freeze; with Itypes; use Itypes; with Lib.Xref; use Lib.Xref; +with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -53,6 +54,7 @@ with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; with Style; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -259,7 +261,7 @@ package body Sem_Ch9 is Set_Accept_Address (Accept_Id, New_Elmt_List); if Present (Formals) then - New_Scope (Accept_Id); + Push_Scope (Accept_Id); Process_Formals (Formals, N); Create_Extra_Formals (Accept_Id); End_Scope; @@ -418,7 +420,7 @@ package body Sem_Ch9 is -- Analyze statements if present if Present (Stats) then - New_Scope (Entry_Nam); + Push_Scope (Entry_Nam); Install_Declarations (Entry_Nam); Set_Actual_Subtypes (N, Current_Scope); @@ -571,7 +573,6 @@ package body Sem_Ch9 is procedure Analyze_Delay_Relative (N : Node_Id) is E : constant Node_Id := Expression (N); - begin Check_Restriction (No_Relative_Delay, N); Tasking_Used := True; @@ -730,7 +731,7 @@ package body Sem_Ch9 is end if; Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name); - New_Scope (Entry_Name); + Push_Scope (Entry_Name); Exp_Ch9.Expand_Entry_Body_Declarations (N); Install_Declarations (Entry_Name); @@ -847,7 +848,7 @@ package body Sem_Ch9 is if Present (Formals) then Set_Scope (Id, Current_Scope); - New_Scope (Id); + Push_Scope (Id); Process_Formals (Formals, Parent (N)); End_Scope; end if; @@ -912,7 +913,7 @@ package body Sem_Ch9 is if Present (Formals) then Set_Scope (Id, Current_Scope); - New_Scope (Id); + Push_Scope (Id); Process_Formals (Formals, N); Create_Extra_Formals (Id); End_Scope; @@ -961,7 +962,7 @@ package body Sem_Ch9 is Set_Ekind (Loop_Id, E_Loop); Set_Scope (Loop_Id, Current_Scope); - New_Scope (Loop_Id); + Push_Scope (Loop_Id); Enter_Name (Iden); Set_Ekind (Iden, E_Entry_Index_Parameter); Set_Etype (Iden, Etype (Def)); @@ -1018,7 +1019,7 @@ package body Sem_Ch9 is Spec_Id := Etype (Spec_Id); end if; - New_Scope (Spec_Id); + Push_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Parent (Spec_Id), Body_Id); Set_Has_Completion (Spec_Id); @@ -1127,7 +1128,7 @@ package body Sem_Ch9 is Set_Etype (T, T); Set_Has_Delayed_Freeze (T, True); Set_Stored_Constraint (T, No_Elist); - New_Scope (T); + Push_Scope (T); -- Ada 2005 (AI-345) @@ -1149,19 +1150,15 @@ package body Sem_Ch9 is Freeze_Before (N, Etype (Iface)); -- Ada 2005 (AI-345): Protected types can only implement - -- limited, synchronized or protected interfaces. - - if Is_Limited_Interface (Iface_Typ) - or else Is_Protected_Interface (Iface_Typ) - or else Is_Synchronized_Interface (Iface_Typ) - then - null; + -- limited, synchronized, or protected interfaces (note that + -- the predicate Is_Limited_Interface includes synchronized + -- and protected interfaces). - elsif Is_Task_Interface (Iface_Typ) then + if Is_Task_Interface (Iface_Typ) then Error_Msg_N ("(Ada 2005) protected type cannot implement a " & "task interface", Iface); - else + elsif not Is_Limited_Interface (Iface_Typ) then Error_Msg_N ("(Ada 2005) protected type cannot implement a " & "non-limited interface", Iface); end if; @@ -1214,6 +1211,17 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); + -- Perform minimal expansion of the protected type while inside of a + -- generic. The corresponding record is needed for various semantic + -- checks. + + if Ada_Version >= Ada_05 + and then Inside_A_Generic + then + Insert_After_And_Analyze (N, + Build_Corresponding_Record (N, T, Sloc (T))); + end if; + Analyze (Protected_Definition (N)); -- Protected types with entries are controlled (because of the @@ -1264,8 +1272,10 @@ package body Sem_Ch9 is -- may be subtypes of the partial view. Skip if errors are present, -- to prevent cascaded messages. - if Serious_Errors_Detected = 0 then - Exp_Ch9.Expand_N_Protected_Type_Declaration (N); + if Serious_Errors_Detected = 0 + and then Expander_Active + then + Expand_N_Protected_Type_Declaration (N); Process_Full_View (N, T, Def_Id); end if; end if; @@ -1444,6 +1454,13 @@ package body Sem_Ch9 is Generate_Reference (Entry_Id, Entry_Name); if Present (First_Formal (Entry_Id)) then + if VM_Target = JVM_Target then + Error_Msg_N + ("arguments unsupported in requeue statement", + First_Formal (Entry_Id)); + return; + end if; + Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N)); -- Processing for parameters accessed by the requeue @@ -1613,7 +1630,7 @@ package body Sem_Ch9 is T : Entity_Id; T_Decl : Node_Id; O_Decl : Node_Id; - O_Name : constant Entity_Id := New_Copy (Id); + O_Name : constant Entity_Id := Id; begin Generate_Definition (Id); @@ -1669,7 +1686,7 @@ package body Sem_Ch9 is T : Entity_Id; T_Decl : Node_Id; O_Decl : Node_Id; - O_Name : constant Entity_Id := New_Copy (Id); + O_Name : constant Entity_Id := Id; begin Generate_Definition (Id); @@ -1688,6 +1705,14 @@ package body Sem_Ch9 is Task_Definition => Relocate_Node (Task_Definition (N)), Interface_List => Interface_List (N)); + -- We use the original defining identifier of the single task in the + -- generated object declaration, so that debugging information can + -- be attached to it when compiling with -gnatD. The parent of the + -- entity is the new object declaration. The single_task_declaration + -- is not used further in semantics or code generation, but is scanned + -- when generating debug information, and therefore needs the updated + -- Sloc information for the entity (see Sprint). + O_Decl := Make_Object_Declaration (Loc, Defining_Identifier => O_Name, @@ -1721,6 +1746,7 @@ package body Sem_Ch9 is procedure Analyze_Task_Body (N : Node_Id) is Body_Id : constant Entity_Id := Defining_Identifier (N); + HSS : constant Node_Id := Handled_Statement_Sequence (N); Last_E : Entity_Id; Spec_Id : Entity_Id; @@ -1779,7 +1805,7 @@ package body Sem_Ch9 is Spec_Id := Etype (Spec_Id); end if; - New_Scope (Spec_Id); + Push_Scope (Spec_Id); Set_Corresponding_Spec (N, Spec_Id); Set_Corresponding_Body (Parent (Spec_Id), Body_Id); Set_Has_Completion (Spec_Id); @@ -1800,7 +1826,24 @@ package body Sem_Ch9 is end if; end if; - Analyze (Handled_Statement_Sequence (N)); + -- Mark all handlers as not suitable for local raise optimization, + -- since this optimization causes difficulties in a task context. + + if Present (Exception_Handlers (HSS)) then + declare + Handlr : Node_Id; + begin + Handlr := First (Exception_Handlers (HSS)); + while Present (Handlr) loop + Set_Local_Raise_Not_OK (Handlr); + Next (Handlr); + end loop; + end; + end if; + + -- Now go ahead and complete analysis of the task body + + Analyze (HSS); Check_Completion (Body_Id); Check_References (Body_Id); Check_References (Spec_Id); @@ -1824,7 +1867,7 @@ package body Sem_Ch9 is end loop; end; - Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id); + Process_End_Label (HSS, 't', Ref_Id); End_Scope; end Analyze_Task_Body; @@ -1887,7 +1930,7 @@ package body Sem_Ch9 is Set_Etype (T, T); Set_Has_Delayed_Freeze (T, True); Set_Stored_Constraint (T, No_Elist); - New_Scope (T); + Push_Scope (T); -- Ada 2005 (AI-345) @@ -1909,19 +1952,15 @@ package body Sem_Ch9 is Freeze_Before (N, Etype (Iface)); -- Ada 2005 (AI-345): Task types can only implement limited, - -- synchronized or task interfaces. - - if Is_Limited_Interface (Iface_Typ) - or else Is_Synchronized_Interface (Iface_Typ) - or else Is_Task_Interface (Iface_Typ) - then - null; + -- synchronized, or task interfaces (note that the predicate + -- Is_Limited_Interface includes synchronized and task + -- interfaces). - elsif Is_Protected_Interface (Iface_Typ) then + if Is_Protected_Interface (Iface_Typ) then Error_Msg_N ("(Ada 2005) task type cannot implement a " & "protected interface", Iface); - else + elsif not Is_Limited_Interface (Iface_Typ) then Error_Msg_N ("(Ada 2005) task type cannot implement a " & "non-limited interface", Iface); end if; @@ -1978,6 +2017,15 @@ package body Sem_Ch9 is Set_Is_Constrained (T, not Has_Discriminants (T)); + -- Perform minimal expansion of the task type while inside a generic + -- context. The corresponding record is needed for various semantic + -- checks. + + if Inside_A_Generic then + Insert_After_And_Analyze (N, + Build_Corresponding_Record (N, T, Sloc (T))); + end if; + if Present (Task_Definition (N)) then Analyze_Task_Definition (Task_Definition (N)); end if; @@ -2006,8 +2054,10 @@ package body Sem_Ch9 is -- may be subtypes of the partial view. Skip if errors are present, -- to prevent cascaded messages. - if Serious_Errors_Detected = 0 then - Exp_Ch9.Expand_N_Task_Type_Declaration (N); + if Serious_Errors_Detected = 0 + and then Expander_Active + then + Expand_N_Task_Type_Declaration (N); Process_Full_View (N, T, Def_Id); end if; end if; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 5d81004dace..3b2a18ad3b1 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- 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- -- @@ -29,11 +29,10 @@ with Debug; use Debug; with Elists; use Elists; with Einfo; use Einfo; with Exp_Disp; use Exp_Disp; -with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Tss; use Exp_Tss; with Errout; use Errout; -with Hostparm; use Hostparm; +with Namet; use Namet; with Nlists; use Nlists; with Nmake; use Nmake; with Opt; use Opt; @@ -48,6 +47,7 @@ with Sem_Util; use Sem_Util; with Snames; use Snames; with Stand; use Stand; with Sinfo; use Sinfo; +with Targparm; use Targparm; with Tbuild; use Tbuild; with Uintp; use Uintp; @@ -102,6 +102,17 @@ package body Sem_Disp is Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); if Present (Ctrl_Type) then + + -- When the controlling type is concurrent and declared within a + -- generic or inside an instance, use its corresponding record + -- type. + + if Is_Concurrent_Type (Ctrl_Type) + and then Present (Corresponding_Record_Type (Ctrl_Type)) + then + Ctrl_Type := Corresponding_Record_Type (Ctrl_Type); + end if; + if Ctrl_Type = Typ then Set_Is_Controlling_Formal (Formal); @@ -162,8 +173,17 @@ package body Sem_Disp is Set_Has_Controlling_Result (Subp); -- Check that result subtype statically matches first subtype + -- (Ada 2005) : Subp may have a controlling access result. - if not Subtypes_Statically_Match (Typ, Etype (Subp)) then + if Subtypes_Statically_Match (Typ, Etype (Subp)) + or else (Ekind (Etype (Subp)) = E_Anonymous_Access_Type + and then + Subtypes_Statically_Match + (Typ, Designated_Type (Etype (Subp)))) + then + null; + + else Error_Msg_N ("result subtype does not match controlling type", Subp); end if; @@ -257,12 +277,12 @@ package body Sem_Disp is ---------------------------- procedure Check_Dispatching_Call (N : Node_Id) is + Loc : constant Source_Ptr := Sloc (N); Actual : Node_Id; Formal : Entity_Id; Control : Node_Id := Empty; Func : Entity_Id; Subp_Entity : Entity_Id; - Loc : constant Source_Ptr := Sloc (N); Indeterm_Ancestor_Call : Boolean := False; Indeterm_Ctrl_Type : Entity_Id; @@ -436,25 +456,6 @@ package body Sem_Disp is Set_Controlling_Argument (N, Control); Check_Restriction (No_Dispatching_Calls, N); - -- Ada 2005 (AI-318-02): Check current implementation restriction - -- that a dispatching call cannot be made to a primitive function - -- with a limited result type. This restriction can be removed - -- once calls to limited functions with class-wide results are - -- supported. ??? - - if Ada_Version = Ada_05 - and then Nkind (N) = N_Function_Call - then - Func := Entity (Name (N)); - - if Has_Controlling_Result (Func) - and then Is_Limited_Type (Etype (Func)) - then - Error_Msg_N ("(Ada 2005) limited function call in this" & - " context is not yet implemented", N); - end if; - end if; - else -- The call is not dispatching, so check that there aren't any -- tag-indeterminate abstract calls left. @@ -479,7 +480,7 @@ package body Sem_Disp is Func := Empty; -- Only other possibility is a qualified expression whose - -- consituent expression is itself a call. + -- constituent expression is itself a call. else Func := @@ -596,6 +597,7 @@ package body Sem_Disp is and then Is_Interface (Typ) and then not Is_Derived_Type (Typ) and then not Is_Generic_Type (Typ) + and then not In_Instance then Error_Msg_N ("?declaration of& is too late!", Subp); Error_Msg_NE @@ -738,8 +740,9 @@ package body Sem_Disp is Set_DT_Position (Subp, DT_Position (Old_Subp)); if not Restriction_Active (No_Dispatching_Calls) then - Insert_After (Subp_Body, - Fill_DT_Entry (Sloc (Subp_Body), Subp)); + Register_Primitive (Sloc (Subp_Body), + Prim => Subp, + Ins_Nod => Subp_Body); end if; end if; end if; @@ -752,7 +755,7 @@ package body Sem_Disp is Subp); end if; - -- If the type is not frozen yet and we are not in the overridding + -- If the type is not frozen yet and we are not in the overriding -- case it looks suspiciously like an attempt to define a primitive -- operation. @@ -769,7 +772,7 @@ package body Sem_Disp is end if; -- Now, we are sure that the scope is a package spec. If the subprogram - -- is declared after the freezing point ot the type that's an error + -- is declared after the freezing point of the type that's an error elsif Is_Frozen (Tagged_Type) and then not Has_Dispatching_Parent then Error_Msg_N ("this primitive operation is declared too late", Subp); @@ -819,13 +822,15 @@ package body Sem_Disp is and then Present (Abstract_Interface_Alias (Prim)) and then Alias (Prim) = Subp then - Register_Interface_DT_Entry (Subp_Body, Prim); + Register_Primitive (Sloc (Prim), + Prim => Prim, + Ins_Nod => Subp_Body); end if; Next_Elmt (Elmt); end loop; - -- Redisplay the contents of the updated dispatch table. + -- Redisplay the contents of the updated dispatch table if Debug_Flag_ZZ then Write_Str ("Late overriding: "); @@ -1322,7 +1327,7 @@ package body Sem_Disp is and then Has_Abstract_Interfaces (Tagged_Type) then -- Ada 2005 (AI-251): Update the attribute alias of all the aliased - -- entities of the overriden primitive to reference New_Op, and also + -- entities of the overridden primitive to reference New_Op, and also -- propagate them the new value of the attribute -- Is_Abstract_Subprogram. @@ -1429,11 +1434,11 @@ package body Sem_Disp is Next_Actual (Arg); end loop; - -- Expansion of dispatching calls is suppressed when Java_VM, because - -- the JVM back end directly handles the generation of dispatching + -- Expansion of dispatching calls is suppressed when VM_Target, because + -- the VM back-ends directly handle the generation of dispatching -- calls and would have to undo any expansion to an indirect call. - if not Java_VM then + if VM_Target = No_VM then Expand_Dispatching_Call (Call_Node); end if; end Propagate_Tag;