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

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;