[multiple changes]

2010-10-11  Robert Dewar  <dewar@adacore.com>

	* aspects.ads, aspects.adb: Major revision of this package for 2nd
	stage of aspects implementation.
	* gcc-interface/Make-lang.in: Add entry for aspects.o
	* gcc-interface/Makefile.in: Add aspects.o to GNATMAKE_OBJS
	* par-ch13.adb (Aspect_Specifications_Present): New function
	(P_Aspect_Specifications): New procedure
	* par-ch3.adb (P_Type_Declaration): Handle aspect specifications
	(P_Derived_Type_Def_Or_Private_Ext_Decl): Handle aspect specifications
	(P_Identifier_Declarations): Handle aspect specifications
	(P_Component_Items): Handle aspect specifications
	(P_Subtype_Declaration): Handle aspect specifications
	* par-ch6.adb (P_Subprogram): Handle aspect specifications
	* par-ch9.adb (P_Entry_Declaration): Handle aspect specifications
	* par.adb (Aspect_Specifications_Present): New function
	(P_Aspect_Specifications): New procedure
	* sem.adb (Analyze_Full_Type_Declaration): New name for
	Analyze_Type_Declaration.
	(Analyze_Formal_Package_Declaration): New name (add _Declaration)
	(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
	(Analyze_Protected_Type_Declaration): New name (add _Declaration)
	(Analyze_Single_Protected_Declaration): New name (add _Declaration)
	(Analyze_Single_Task_Declaration): New name (add _Declaration)
	(Analyze_Task_Type_Declaration): New name (add _Declaration)
	* sem_cat.adb (Analyze_Full_Type_Declaration): New name for
	Analyze_Type_Declaration.
	* sem_ch11.adb (Analyze_Exception_Declaration): Analyze aspect
	specifications.
	* sem_ch12.adb (Analyze_Formal_Object_Declaration): Handle aspect
	specifications.
	(Analyze_Formal_Package_Declaration): New name (add _Declaration)
	(Analyze_Formal_Package_Declaration): Handle aspect specifications
	(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
	(Analyze_Formal_Subprogram_Declaration): Handle aspect specifications
	(Analyze_Formal_Type_Declaration): Handle aspect specifications
	(Analyze_Generic_Package_Declaration): Handle aspect specifications
	(Analyze_Generic_Subprogram_Declaration): Handle aspect specifications
	(Analyze_Package_Instantiation): Handle aspect specifications
	(Analyze_Subprogram_Instantiation): Handle aspect specifications
	* sem_ch12.ads (Analyze_Formal_Package_Declaration): New name (add
	_Declaration).
	(Analyze_Formal_Subprogram_Declaration): New name (add _Declaration)
	* sem_ch13.adb (Analyze_Aspect_Specifications): New procedure
	(Duplicate_Clause): New function, calls to this function are added to
	processing for all aspects.
	* sem_ch13.ads (Analyze_Aspect_Specifications): New procedure
	* sem_ch3.adb (Analyze_Full_Type_Declaration): New name for
	Analyze_Type_Declaration.
	* sem_ch3.ads (Analyze_Full_Type_Declaration): New name for
	Analyze_Type_Declaration.
	* sem_ch6.adb (Analyze_Abstract_Subprogram_Declaration): Analyze aspect
	specifications.
	(Analyze_Subprogram_Declaration): Analyze aspect specifications
	* sem_ch7.adb (Analyze_Package_Declaration): Analyze aspect
	specifications.
	(Analyze_Private_Type_Declaration): Analyze aspect specifications
	* sem_ch9.adb (Analyze_Protected_Type_Declaration): Analyze aspect
	specifications.
	(Analyze_Protected_Type_Declaration): New name (add _Declaration)
	(Analyze_Single_Protected_Declaration): Analyze aspect specifications
	(Analyze_Single_Protected_Declaration): New name (add _Declaration)
	(Analyze_Single_Task_Declaration): Analyze aspect specifications
	(Analyze_Single_Task_Declaration): New name (add _Declaration)
	(Analyze_Task_Type_Declaration): Analyze aspect specifications
	(Analyze_Task_Type_Declaration): New name (add _Declaration)
	* sem_ch9.ads (Analyze_Protected_Type_Declaration): New name (add
	_Declaration).
	(Analyze_Single_Protected_Declaration): New name (add _Declaration)
	(Analyze_Single_Task_Declaration): New name (add _Declaration)
	(Analyze_Task_Type_Declaration): New name (add _Declaration)
	* sem_prag.adb: Use Get_Pragma_Arg systematically so that we do not
	have to generate unnecessary pragma argument associations (this matches
	the doc).
	Throughout do changes to accomodate aspect specifications, including
	specializing messages, handling the case of not going through all
	homonyms, and allowing for cancellation.
	* sinfo.ads, sinfo.adb: Clean up obsolete documentation for Flag1,2,3
	(Aspect_Cancel): New flag
	(From_Aspect_Specification): New flag
	(First_Aspect): Removed flag
	(Last_Aspect): Removed flag
	* sprint.adb (Sprint_Aspect_Specifications): New procedure
	(Sprint_Node_Actual): Add calls to Sprint_Aspect_Specifications

2010-10-11  Bob Duff  <duff@adacore.com>

	* sem_res.adb (Resolve_Actuals): Minor change to warning messages so
	they match in Ada 95, 2005, and 2012 modes, in the case where the
	language didn't change. Same thing for the run-time exception message.

2010-10-11  Javier Miranda  <miranda@adacore.com>

	* debug.adb Document that switch -gnatd.p enables the CIL verifier.

2010-10-11  Robert Dewar  <dewar@adacore.com>

	* s-htable.adb: Minor reformatting.

From-SVN: r165299

1 files changed, 118 insertions, 66 deletions

diff --git a/gcc/ada/sprint.adb b/gcc/ada/sprint.adb
index c35ef0d..74da13f 100644
--- a/gcc/ada/sprint.adb
+++ b/gcc/ada/sprint.adb
@@ -23,6 +23,7 @@
 --                                                                          --
 ------------------------------------------------------------------------------
 
+with Aspects;  use Aspects;
 with Atree;    use Atree;
 with Casing;   use Casing;
 with Csets;    use Csets;
@@ -182,6 +183,12 @@ package body Sprint is
    procedure Sprint_And_List (List : List_Id);
    --  Print the given list with items separated by vertical "and"
 
+   procedure Sprint_Aspect_Specifications (Node : Node_Id);
+   --  Node is a declaration node that accepts aspect specifications. This
+   --  procedure tests if aspect specifications are present, and if so prints
+   --  them, with a terminating semicolon. If no aspect specifications are
+   --  present, then a single semicolon is output.
+
    procedure Sprint_Bar_List (List : List_Id);
    --  Print the given list with items separated by vertical bars
 
@@ -619,6 +626,48 @@ package body Sprint is
       end if;
    end Sprint_And_List;
 
+   ----------------------------------
+   -- Sprint_Aspect_Specifications --
+   ----------------------------------
+
+   procedure Sprint_Aspect_Specifications (Node : Node_Id) is
+      AS : List_Id;
+      A  : Node_Id;
+
+   begin
+      if Has_Aspect_Specifications (Node) then
+         AS := Aspect_Specifications (Node);
+         Indent := Indent + 2;
+         Write_Indent;
+         Write_Str ("with ");
+         Indent := Indent + 5;
+
+         A := First (AS);
+         loop
+            Sprint_Node (Identifier (A));
+
+            if Class_Present (A) then
+               Write_Str ("'Class");
+            end if;
+
+            if Present (Expression (A)) then
+               Write_Str (" => ");
+               Sprint_Node (Expression (A));
+            end if;
+
+            Next (A);
+
+            exit when No (A);
+            Write_Char (',');
+            Write_Indent;
+         end loop;
+
+         Indent := Indent - 7;
+      end if;
+
+      Write_Char (';');
+   end Sprint_Aspect_Specifications;
+
    ---------------------
    -- Sprint_Bar_List --
    ---------------------
@@ -815,7 +864,8 @@ package body Sprint is
             Write_Indent;
             Sprint_Node (Specification (Node));
             Write_Str_With_Col_Check (" is ");
-            Write_Str_Sloc ("abstract;");
+            Write_Str_Sloc ("abstract");
+            Sprint_Aspect_Specifications (Node);
 
          when N_Accept_Alternative =>
             Sprint_Node_List (Pragmas_Before (Node));
@@ -1224,7 +1274,7 @@ package body Sprint is
                   Sprint_Node (Expression (Node));
                end if;
 
-               Write_Char (';');
+               Sprint_Aspect_Specifications (Node);
             end if;
 
          when N_Component_List =>
@@ -1453,7 +1503,7 @@ package body Sprint is
             end if;
 
             Write_Param_Specs (Node);
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Entry_Index_Specification =>
             Write_Str_With_Col_Check_Sloc ("for ");
@@ -1499,7 +1549,7 @@ package body Sprint is
                   Sprint_Node (Expression (Node));
                end if;
 
-               Write_Char (';');
+               Sprint_Aspect_Specifications (Node);
             end if;
 
          when N_Exception_Handler =>
@@ -1625,7 +1675,7 @@ package body Sprint is
                Sprint_Node (Default_Name (Node));
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Formal_Concrete_Subprogram_Declaration =>
             Write_Indent_Str_Sloc ("with ");
@@ -1638,7 +1688,7 @@ package body Sprint is
                Sprint_Node (Default_Name (Node));
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Formal_Discrete_Type_Definition =>
             Write_Str_With_Col_Check_Sloc ("<>");
@@ -1686,7 +1736,7 @@ package body Sprint is
                   Sprint_Node (Default_Expression (Node));
                end if;
 
-               Write_Char (';');
+               Sprint_Aspect_Specifications (Node);
             end if;
 
          when N_Formal_Ordinary_Fixed_Point_Definition =>
@@ -1697,7 +1747,8 @@ package body Sprint is
             Write_Id (Defining_Identifier (Node));
             Write_Str_With_Col_Check (" is new ");
             Sprint_Node (Name (Node));
-            Write_Str_With_Col_Check (" (<>);");
+            Write_Str_With_Col_Check (" (<>)");
+            Sprint_Aspect_Specifications (Node);
 
          when N_Formal_Private_Type_Definition =>
             if Abstract_Present (Node) then
@@ -1729,7 +1780,7 @@ package body Sprint is
 
             Write_Str_With_Col_Check (" is ");
             Sprint_Node (Formal_Type_Definition (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Free_Statement =>
             Write_Indent_Str_Sloc ("free ");
@@ -1770,7 +1821,7 @@ package body Sprint is
             Write_Discr_Specs (Node);
             Write_Str_With_Col_Check (" is ");
             Sprint_Node (Type_Definition (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Function_Call =>
             Set_Debug_Sloc;
@@ -1783,7 +1834,7 @@ package body Sprint is
             Write_Str_With_Col_Check (" is new ");
             Sprint_Node (Name (Node));
             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Function_Specification =>
             Write_Str_With_Col_Check_Sloc ("function ");
@@ -1824,7 +1875,7 @@ package body Sprint is
             Sprint_Indented_List (Generic_Formal_Declarations (Node));
             Write_Indent;
             Sprint_Node (Specification (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Generic_Package_Renaming_Declaration =>
             Write_Indent_Str_Sloc ("generic package ");
@@ -1846,7 +1897,7 @@ package body Sprint is
             Sprint_Indented_List (Generic_Formal_Declarations (Node));
             Write_Indent;
             Sprint_Node (Specification (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Goto_Statement =>
             Write_Indent_Str_Sloc ("goto ");
@@ -2077,7 +2128,7 @@ package body Sprint is
                      Sprint_Node (Expression (Node));
                   end if;
 
-                  Write_Char (';');
+                  Sprint_Aspect_Specifications (Node);
 
                   --  Handle implicit importation and implicit exportation of
                   --  object declarations:
@@ -2318,7 +2369,7 @@ package body Sprint is
             Extra_Blank_Line;
             Write_Indent;
             Sprint_Node_Sloc (Specification (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Package_Instantiation =>
             Extra_Blank_Line;
@@ -2327,7 +2378,7 @@ package body Sprint is
             Write_Str (" is new ");
             Sprint_Node (Name (Node));
             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Package_Renaming_Declaration =>
             Write_Indent_Str_Sloc ("package ");
@@ -2410,6 +2461,50 @@ package body Sprint is
          when N_Pop_Storage_Error_Label =>
             Write_Indent_Str ("%pop_storage_error_label");
 
+         when N_Private_Extension_Declaration =>
+            Write_Indent_Str_Sloc ("type ");
+            Write_Id (Defining_Identifier (Node));
+
+            if Present (Discriminant_Specifications (Node)) then
+               Write_Discr_Specs (Node);
+            elsif Unknown_Discriminants_Present (Node) then
+               Write_Str_With_Col_Check ("(<>)");
+            end if;
+
+            Write_Str_With_Col_Check (" is new ");
+            Sprint_Node (Subtype_Indication (Node));
+
+            if Present (Interface_List (Node)) then
+               Write_Str_With_Col_Check (" and ");
+               Sprint_And_List (Interface_List (Node));
+            end if;
+
+            Write_Str_With_Col_Check (" with private");
+            Sprint_Aspect_Specifications (Node);
+
+         when N_Private_Type_Declaration =>
+            Write_Indent_Str_Sloc ("type ");
+            Write_Id (Defining_Identifier (Node));
+
+            if Present (Discriminant_Specifications (Node)) then
+               Write_Discr_Specs (Node);
+            elsif Unknown_Discriminants_Present (Node) then
+               Write_Str_With_Col_Check ("(<>)");
+            end if;
+
+            Write_Str (" is ");
+
+            if Tagged_Present (Node) then
+               Write_Str_With_Col_Check ("tagged ");
+            end if;
+
+            if Limited_Present (Node) then
+               Write_Str_With_Col_Check ("limited ");
+            end if;
+
+            Write_Str_With_Col_Check ("private");
+            Sprint_Aspect_Specifications (Node);
+
          when N_Push_Constraint_Error_Label =>
             Write_Indent_Str ("%push_constraint_error_label (");
 
@@ -2458,48 +2553,6 @@ package body Sprint is
 
             Sprint_Node (Expression (Node));
 
-         when N_Private_Type_Declaration =>
-            Write_Indent_Str_Sloc ("type ");
-            Write_Id (Defining_Identifier (Node));
-
-            if Present (Discriminant_Specifications (Node)) then
-               Write_Discr_Specs (Node);
-            elsif Unknown_Discriminants_Present (Node) then
-               Write_Str_With_Col_Check ("(<>)");
-            end if;
-
-            Write_Str (" is ");
-
-            if Tagged_Present (Node) then
-               Write_Str_With_Col_Check ("tagged ");
-            end if;
-
-            if Limited_Present (Node) then
-               Write_Str_With_Col_Check ("limited ");
-            end if;
-
-            Write_Str_With_Col_Check ("private;");
-
-         when N_Private_Extension_Declaration =>
-            Write_Indent_Str_Sloc ("type ");
-            Write_Id (Defining_Identifier (Node));
-
-            if Present (Discriminant_Specifications (Node)) then
-               Write_Discr_Specs (Node);
-            elsif Unknown_Discriminants_Present (Node) then
-               Write_Str_With_Col_Check ("(<>)");
-            end if;
-
-            Write_Str_With_Col_Check (" is new ");
-            Sprint_Node (Subtype_Indication (Node));
-
-            if Present (Interface_List (Node)) then
-               Write_Str_With_Col_Check (" and ");
-               Sprint_And_List (Interface_List (Node));
-            end if;
-
-            Write_Str_With_Col_Check (" with private;");
-
          when N_Procedure_Call_Statement =>
             Write_Indent;
             Set_Debug_Sloc;
@@ -2513,7 +2566,7 @@ package body Sprint is
             Write_Str_With_Col_Check (" is new ");
             Sprint_Node (Name (Node));
             Sprint_Opt_Paren_Comma_List (Generic_Associations (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Procedure_Specification =>
             Write_Str_With_Col_Check_Sloc ("procedure ");
@@ -2560,7 +2613,7 @@ package body Sprint is
 
             Sprint_Node (Protected_Definition (Node));
             Write_Id (Defining_Identifier (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Qualified_Expression =>
             Sprint_Node (Subtype_Mark (Node));
@@ -2756,7 +2809,7 @@ package body Sprint is
             Write_Str (" is");
             Sprint_Node (Protected_Definition (Node));
             Write_Id (Defining_Identifier (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Single_Task_Declaration =>
             Write_Indent_Str_Sloc ("task ");
@@ -2767,7 +2820,7 @@ package body Sprint is
                Sprint_Node (Task_Definition (Node));
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Selected_Component =>
             Sprint_Node (Prefix (Node));
@@ -2840,7 +2893,7 @@ package body Sprint is
                Write_Str_With_Col_Check (" is null");
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Subprogram_Info =>
             Sprint_Node (Identifier (Node));
@@ -2865,7 +2918,7 @@ package body Sprint is
             end if;
 
             Sprint_Node (Subtype_Indication (Node));
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Subtype_Indication =>
             Sprint_Node_Sloc (Subtype_Mark (Node));
@@ -2928,11 +2981,10 @@ package body Sprint is
                Sprint_Node (Task_Definition (Node));
             end if;
 
-            Write_Char (';');
+            Sprint_Aspect_Specifications (Node);
 
          when N_Terminate_Alternative =>
             Sprint_Node_List (Pragmas_Before (Node));
-
             Write_Indent;
 
             if Present (Condition (Node)) then