2006-02-13 Thomas Quinot <quinot@adacore.com>

	    Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>
	    Javier Miranda  <miranda@adacore.com>

	* sem_ch12.adb (Inline_Instance_Body): Remove erroneous assumption
	that Scope_Stack.First = 1.
	Properly handle Ada_Version_Explicit and Ada_Version_Config, which
	were not always properly handled previously.
	(Formal_Entity): Complete rewrite, to handle properly some complex case
	with multiple levels of parametrization by formal packages.
	(Analyze_Formal_Derived_Type): Propagate Ada 2005 "limited" indicator
	to the corresponding derived type declaration for proper semantics.

	* sem_prag.adb (Analyze_Pragma): Remove '!' in warning message.
	(Check_Component): Enforce restriction on components of
	unchecked_unions: a component in a variant cannot contain tasks or
	controlled types.
	(Unchecked_Union): Allow nested variants and multiple discriminants, to
	conform to AI-216.
	Add pragma Ada_2005 (synonym for Ada_05)
	Properly handle Ada_Version_Explicit and Ada_Version_Config, which
	were not always properly handled previously.
	Document that pragma Propagate_Exceptions has no effect
	(Analyze_Pragma, case Pure): Set new flag Has_Pragma_Pure
	(Set_Convention_From_Pragma): Check that if a convention is
	specified for a dispatching operation, then it must be
	consistent with the existing convention for the operation.
	(CPP_Class): Because of the C++ ABI compatibility, the programmer is no
	longer required to specify an vtable-ptr component in the record. For
	compatibility reasons we leave the support for the previous definition.
	(Analyze_Pragma, case No_Return): Allow multiple arguments

	* sem_ch3.ads, sem_ch3.adb (Check_Abstract_Overriding): Flag a
	non-overrideen inherited operation with a controlling result as
	illegal only its implicit declaration comes from the derived type
	declaration of its result's type.
	(Check_Possible_Deferred_Completion): Relocate the object definition
	node of the subtype indication of a deferred constant completion rather
	than directly analyzing it. The analysis of the generated subtype will
	correctly decorate the GNAT tree.
	(Record_Type_Declaration): Check whether this is a declaration for a
	limited derived record before analyzing components.
	(Analyze_Component_Declaration): Diagnose record types  not explicitly
	declared limited when a component has a limited type.
	(Build_Derived_Record_Type): Code reorganization to check if some of
	the inherited subprograms of a tagged type cover interface primitives.
	This check was missing in case of a full-type associated with a private
	type declaration.
	(Constant_Redeclaration): Check that the subtypes of the partial and the
	full view of a constrained deferred constant statically match.
	(Mentions_T): A reference to the current type in an anonymous access
	component declaration  must be an entity name.
	(Make_Incomplete_Type_Declaration): If type is tagged, set type of
	class_wide type to refer to full type, not to the incomplete one.
	(Add_Interface_Tag_Components): Do nothing if RE_Interface_Tag is not
	available. Required to give support to the certified run-time.
	(Analyze_Component_Declaration): In case of anonymous access components
	perform missing checks for AARM 3.9.2(9) and 3.10.2 (12.2).
	(Process_Discriminants): For an access discriminant, use the
	discriminant specification as the associated_node_for_itype, to
	simplify accessibility checks.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@111091 138bc75d-0d04-0410-961f-82ee72b054a4

1 files changed, 104 insertions, 70 deletions

diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 1610c2848a7..bec0eb5e8c0 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2005, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2006, 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- --
@@ -341,7 +341,7 @@ package body Sem_Prag is
 
       procedure Check_Component (Comp : Node_Id);
       --  Examine Unchecked_Union component for correct use of per-object
-      --  constrained subtypes.
+      --  constrained subtypes, and for restrictions on finalizable components.
 
       procedure Check_Duplicated_Export_Name (Nam : Node_Id);
       --  Nam is an N_String_Literal node containing the external name set
@@ -988,7 +988,8 @@ package body Sem_Prag is
             declare
                Sindic : constant Node_Id :=
                           Subtype_Indication (Component_Definition (Comp));
-
+               Typ    : constant Entity_Id :=
+                          Etype (Defining_Identifier (Comp));
             begin
                if Nkind (Sindic) = N_Subtype_Indication then
 
@@ -1004,6 +1005,15 @@ package body Sem_Prag is
                        " constraint must be an Unchecked_Union", Comp);
                   end if;
                end if;
+
+               if Is_Controlled (Typ) then
+                  Error_Msg_N
+                   ("component of unchecked union cannot be controlled", Comp);
+
+               elsif Has_Task (Typ) then
+                  Error_Msg_N
+                   ("component of unchecked union cannot have tasks", Comp);
+               end if;
             end;
          end if;
       end Check_Component;
@@ -1440,12 +1450,6 @@ package body Sem_Prag is
          Comp  : Node_Id;
 
       begin
-         if Present (Variant_Part (Clist)) then
-            Error_Msg_N
-              ("Unchecked_Union may not have nested variants",
-               Variant_Part (Clist));
-         end if;
-
          if not Is_Non_Empty_List (Component_Items (Clist)) then
             Error_Msg_N
               ("Unchecked_Union may not have empty component list",
@@ -1957,6 +1961,24 @@ package body Sem_Prag is
 
          procedure Set_Convention_From_Pragma (E : Entity_Id) is
          begin
+            --  Check invalid attempt to change convention for an overridden
+            --  dispatching operation. This is Ada 2005 AI 430. Technically
+            --  this is an amendment and should only be done in Ada 2005 mode.
+            --  However, this is clearly a mistake, since the problem that is
+            --  addressed by this AI is that there is a clear gap in the RM!
+
+            if Is_Dispatching_Operation (E)
+              and then Present (Overridden_Operation (E))
+              and then C /= Convention (Overridden_Operation (E))
+            then
+               Error_Pragma_Arg
+                 ("cannot change convention for " &
+                  "overridden dispatching operation",
+                  Arg1);
+            end if;
+
+            --  Set the convention
+
             Set_Convention (E, C);
             Set_Has_Convention_Pragma (E);
 
@@ -2862,7 +2884,7 @@ package body Sem_Prag is
                else
                   Dval := Default_Value (Formal);
 
-                  if not Present (Dval) then
+                  if No (Dval) then
                      Error_Msg_NE
                        ("optional formal& does not have default value!",
                         Arg_First_Optional_Parameter, Formal);
@@ -4222,9 +4244,9 @@ package body Sem_Prag is
             Error_Msg_Sloc := Task_Dispatching_Policy_Sloc;
             Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
 
-         --  Set the FIFO_Within_Priorities policy, but always
-         --  preserve System_Location since we like the error
-         --  message with the run time name.
+         --  Set the FIFO_Within_Priorities policy, but always preserve
+         --  System_Location since we like the error message with the run time
+         --  name.
 
          else
             Task_Dispatching_Policy := 'F';
@@ -4242,9 +4264,8 @@ package body Sem_Prag is
             Error_Msg_Sloc := Locking_Policy_Sloc;
             Error_Pragma ("Profile (Ravenscar) incompatible with policy#");
 
-         --  Set the Ceiling_Locking policy, but always preserve
-         --  System_Location since we like the error message with the
-         --  run time name.
+         --  Set the Ceiling_Locking policy, but preserve System_Location since
+         --  we like the error message with the run time name.
 
          else
             Locking_Policy := 'C';
@@ -4268,7 +4289,7 @@ package body Sem_Prag is
    begin
       if not Is_Pragma_Name (Chars (N)) then
          if Warn_On_Unrecognized_Pragma then
-            Error_Pragma ("unrecognized pragma%!?");
+            Error_Pragma ("unrecognized pragma%?");
          else
             return;
          end if;
@@ -4368,17 +4389,20 @@ package body Sem_Prag is
             Ada_Version_Explicit := Ada_Version;
             Check_Arg_Count (0);
 
-         ------------
-         -- Ada_05 --
-         ------------
+         ---------------------
+         -- Ada_05/Ada_2005 --
+         ---------------------
 
          --  pragma Ada_05;
          --  pragma Ada_05 (LOCAL_NAME);
 
-         --  Note: this pragma also has some specific processing in Par.Prag
+         --  pragma Ada_2005;
+         --  pragma Ada_2005 (LOCAL_NAME):
+
+         --  Note: these pragma also have some specific processing in Par.Prag
          --  because we want to set the Ada 2005 version mode during parsing.
 
-         when Pragma_Ada_05 => declare
+         when Pragma_Ada_05 | Pragma_Ada_2005 => declare
             E_Id : Node_Id;
 
          begin
@@ -4397,7 +4421,7 @@ package body Sem_Prag is
             else
                Check_Arg_Count (0);
                Ada_Version := Ada_05;
-               Ada_Version_Explicit := Ada_Version;
+               Ada_Version_Explicit := Ada_05;
             end if;
          end;
 
@@ -4618,7 +4642,7 @@ package body Sem_Prag is
 
             procedure Process_Async_Pragma is
             begin
-               if not Present (L) then
+               if No (L) then
                   Set_Is_Asynchronous (Nm);
                   return;
                end if;
@@ -5255,16 +5279,15 @@ package body Sem_Prag is
                     ("only tagged records can contain vtable pointers", Arg1);
                end if;
 
-            --  Case of tagged type with no vtable ptr
-
-            --  What is test for Typ = Root_Typ (Typ) about here ???
+            --  Case of tagged type with no user-defined vtable ptr. In this
+            --  case, because of our C++ ABI compatibility, the programmer
+            --  does not need to specify the tag component.
 
             elsif Is_Tagged_Type (Typ)
-              and then Typ = Root_Type (Typ)
               and then No (Default_DTC)
             then
-               Error_Pragma_Arg
-                 ("a cpp_class must contain a vtable pointer", Arg1);
+               Set_Is_CPP_Class (Typ);
+               Set_Is_Limited_Record (Typ);
 
             --  Tagged type that has a vtable ptr
 
@@ -5438,6 +5461,8 @@ package body Sem_Prag is
                Next_Component (DTC);
             end loop;
 
+            --  Case of tagged type with no user-defined vtable ptr
+
             if No (DTC) then
                Error_Msg_NE ("must be a& component name", Arg, Typ);
                raise Pragma_Exit;
@@ -8101,48 +8126,57 @@ package body Sem_Prag is
          -- No_Return --
          ---------------
 
-         --  pragma No_Return (procedure_LOCAL_NAME);
+         --  pragma No_Return (procedure_LOCAL_NAME {, procedure_Local_Name});
 
          when Pragma_No_Return => No_Return : declare
             Id    : Node_Id;
             E     : Entity_Id;
             Found : Boolean;
+            Arg   : Node_Id;
 
          begin
             GNAT_Pragma;
-            Check_Arg_Count (1);
-            Check_No_Identifiers;
-            Check_Arg_Is_Local_Name (Arg1);
-            Id := Expression (Arg1);
-            Analyze (Id);
+            Check_At_Least_N_Arguments (1);
 
-            if not Is_Entity_Name (Id) then
-               Error_Pragma_Arg ("entity name required", Arg1);
-            end if;
+            --  Loop through arguments of pragma
 
-            if Etype (Id) = Any_Type then
-               raise Pragma_Exit;
-            end if;
+            Arg := Arg1;
+            while Present (Arg) loop
+               Check_Arg_Is_Local_Name (Arg);
+               Id := Expression (Arg);
+               Analyze (Id);
 
-            E := Entity (Id);
+               if not Is_Entity_Name (Id) then
+                  Error_Pragma_Arg ("entity name required", Arg);
+               end if;
 
-            Found := False;
-            while Present (E)
-              and then Scope (E) = Current_Scope
-            loop
-               if Ekind (E) = E_Procedure
-                 or else Ekind (E) = E_Generic_Procedure
-               then
-                  Set_No_Return (E);
-                  Found := True;
+               if Etype (Id) = Any_Type then
+                  raise Pragma_Exit;
                end if;
 
-               E := Homonym (E);
-            end loop;
+               --  Loop to find matching procedures
 
-            if not Found then
-               Error_Pragma ("no procedures found for pragma%");
-            end if;
+               E := Entity (Id);
+               Found := False;
+               while Present (E)
+                 and then Scope (E) = Current_Scope
+               loop
+                  if Ekind (E) = E_Procedure
+                    or else Ekind (E) = E_Generic_Procedure
+                  then
+                     Set_No_Return (E);
+                     Found := True;
+                  end if;
+
+                  E := Homonym (E);
+               end loop;
+
+               if not Found then
+                  Error_Pragma_Arg ("no procedure & found for pragma%", Arg);
+               end if;
+
+               Next (Arg);
+            end loop;
          end No_Return;
 
          ------------------------
@@ -8181,7 +8215,7 @@ package body Sem_Prag is
          -- Obsolescent --
          -----------------
 
-            --  pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
+         --  pragma Obsolescent [(static_string_EXPRESSION [, Ada_05])];
 
          when Pragma_Obsolescent => Obsolescent : declare
             Subp   : Node_Or_Entity_Id;
@@ -8789,6 +8823,8 @@ package body Sem_Prag is
 
          --  pragma Propagate_Exceptions;
 
+         --  Note: this pragma is obsolete and has no effect
+
          when Pragma_Propagate_Exceptions =>
             GNAT_Pragma;
             Check_Arg_Count (0);
@@ -8956,6 +8992,7 @@ package body Sem_Prag is
 
             Ent := Find_Lib_Unit_Name;
             Set_Is_Pure (Ent);
+            Set_Has_Pragma_Pure (Ent);
             Set_Suppress_Elaboration_Warnings (Ent);
          end Pure;
 
@@ -10146,18 +10183,14 @@ package body Sem_Prag is
 
                Discr := First_Discriminant (Typ);
 
-               if Present (Next_Discriminant (Discr)) then
-                  Error_Msg_N
-                    ("Unchecked_Union must have exactly one discriminant",
-                     Next_Discriminant (Discr));
-                  return;
-               end if;
-
-               if No (Discriminant_Default_Value (Discr)) then
-                  Error_Msg_N
-                    ("Unchecked_Union discriminant must have default value",
-                     Discr);
-               end if;
+               while Present (Discr) loop
+                  if No (Discriminant_Default_Value (Discr)) then
+                     Error_Msg_N
+                       ("Unchecked_Union discriminant must have default value",
+                        Discr);
+                  end if;
+                  Next_Discriminant (Discr);
+               end loop;
 
                Tdef  := Type_Definition (Declaration_Node (Typ));
                Clist := Component_List (Tdef);
@@ -10686,6 +10719,7 @@ package body Sem_Prag is
       Pragma_Ada_83                       => -1,
       Pragma_Ada_95                       => -1,
       Pragma_Ada_05                       => -1,
+      Pragma_Ada_2005                     => -1,
       Pragma_All_Calls_Remote             => -1,
       Pragma_Annotate                     => -1,
       Pragma_Assert                       => -1,