sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the use of…

sem_ch11.adb (Analyze_Exception_Handlers): Add barrier to avoid the use of entity Exception_Occurrence if...

2007-04-20  Javier Miranda  <miranda@adacore.com>
	    Hristian Kirtchev  <kirtchev@adacore.com>
	    Gary Dismukes  <dismukes@adacore.com>

	* 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

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);
+
+               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

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.
+               --  synchronized, or task interfaces (note that the predicate
+               --  Is_Limited_Interface includes synchronized and task
+               --  interfaces).
 
-               if Is_Limited_Interface (Iface_Typ)
-                 or else Is_Synchronized_Interface (Iface_Typ)
-                 or else Is_Task_Interface (Iface_Typ)
-               then
-                  null;
-
-               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;

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;