[multiple changes]

2010-01-27  Vincent Celier  <celier@adacore.com>

	* gnatcmd.adb: When there is only one main specified, the package
	support Switches (<main>) and attribute Switches is specified for the
	main, use these switches, instead of Default_Switches ("Ada").

2010-01-27  Robert Dewar  <dewar@adacore.com>

	* sem_prag.adb, par-prag.adb, snames.ads-tmpl: pragma Dimension initial
	implementation.
	* exp_disp.adb: Minor reformatting

From-SVN: r156283

gcc/ada/ChangeLog

+2010-01-27  Vincent Celier  <celier@adacore.com>
+
+	* gnatcmd.adb: When there is only one main specified, the package
+	support Switches (<main>) and attribute Switches is specified for the
+	main, use these switches, instead of Default_Switches ("Ada").
+
+2010-01-27  Robert Dewar  <dewar@adacore.com>
+
+	* sem_prag.adb, par-prag.adb, snames.ads-tmpl: pragma Dimension initial
+	implementation.
+	* exp_disp.adb: Minor reformatting
+
 2010-01-27  Tristan Gingold  <gingold@adacore.com>
 
 	* seh_init.c: Use __ImageBase instead of _ImageBase.

gcc/ada/exp_disp.adb

@@ -1443,11 +1443,11 @@ package body Exp_Disp is
       Thunk_Id   : out Entity_Id;
       Thunk_Code : out Node_Id)
    is
-      Loc             : constant Source_Ptr := Sloc (Prim);
-      Actuals         : constant List_Id    := New_List;
-      Decl            : constant List_Id    := New_List;
-      Formals         : constant List_Id    := New_List;
-      Target          : constant Entity_Id  := Ultimate_Alias (Prim);
+      Loc     : constant Source_Ptr := Sloc (Prim);
+      Actuals : constant List_Id    := New_List;
+      Decl    : constant List_Id    := New_List;
+      Formals : constant List_Id    := New_List;
+      Target  : constant Entity_Id  := Ultimate_Alias (Prim);
 
       Controlling_Typ : Entity_Id;
       Decl_1          : Node_Id;
@@ -1464,8 +1464,8 @@ package body Exp_Disp is
       Thunk_Id   := Empty;
       Thunk_Code := Empty;
 
-      --  In case of primitives that are functions without formals and
-      --  a controlling result there is no need to build the thunk.
+      --  In case of primitives that are functions without formals and a
+      --  controlling result there is no need to build the thunk.
 
       if not Present (First_Formal (Target)) then
          pragma Assert (Ekind (Target) = E_Function
@@ -1477,8 +1477,8 @@ package body Exp_Disp is
       --  of the controlling formal is the covered interface type (instead of
       --  the target tagged type). Done to avoid problems with discriminated
       --  tagged types because, if the controlling type has discriminants with
-      --  default values, then the type conversions done inside the body of the
-      --  thunk (after the displacement of the pointer to the base of the
+      --  default values, then the type conversions done inside the body of
+      --  the thunk (after the displacement of the pointer to the base of the
       --  actual object) generate code that modify its contents.
 
       --  Note: This special management is not done for predefined primitives
@@ -1493,7 +1493,7 @@ package body Exp_Disp is
          Ftyp := Etype (Formal);
 
          --  Use the interface type as the type of the controlling formal (see
-         --  comment above)
+         --  comment above).
 
          if not Is_Controlling_Formal (Formal)
            or else Is_Predefined_Dispatching_Operation (Prim)
@@ -1547,7 +1547,6 @@ package body Exp_Disp is
            and then Ftyp = Controlling_Typ
          then
             --  Generate:
-
             --     type T is access all <<type of the target formal>>
             --     S : Storage_Offset := Storage_Offset!(Formal)
             --                            - Offset_To_Top (address!(Formal))
@@ -1608,8 +1607,8 @@ package body Exp_Disp is
                  New_Reference_To (Defining_Identifier (Decl_1), Loc)));
 
          elsif Ftyp = Controlling_Typ then
-            --  Generate:
 
+            --  Generate:
             --     S1 : Storage_Offset := Storage_Offset!(Formal'Address)
             --                             - Offset_To_Top (Formal'Address)
             --     S2 : Addr_Ptr := Addr_Ptr!(S1)
@@ -1690,6 +1689,8 @@ package body Exp_Disp is
 
       Set_Is_Thunk (Thunk_Id);
 
+      --  Procedure case
+
       if Ekind (Target) = E_Procedure then
          Thunk_Code :=
            Make_Subprogram_Body (Loc,
@@ -1705,8 +1706,9 @@ package body Exp_Disp is
                       Name => New_Occurrence_Of (Target, Loc),
                       Parameter_Associations => Actuals))));
 
-      else pragma Assert (Ekind (Target) = E_Function);
+      --  Function case
 
+      else pragma Assert (Ekind (Target) = E_Function);
          Thunk_Code :=
            Make_Subprogram_Body (Loc,
               Specification =>

gcc/ada/gnatcmd.adb

@@ -1807,12 +1807,14 @@ begin
 
             Element : Package_Element;
 
-            Default_Switches_Array : Array_Element_Id;
+            Switches_Array : Array_Element_Id;
 
             The_Switches : Prj.Variable_Value;
             Current      : Prj.String_List_Id;
             The_String   : String_Element;
 
+            Main : String_Access := null;
+
          begin
             if Pkg /= No_Package then
                Element := Project_Tree.Packages.Table (Pkg);
@@ -1838,8 +1840,37 @@ begin
                --  name of the programming language.
 
                else
+                  --  First check if there is a single main
+
+                  for J in 1 .. Last_Switches.Last loop
+                     if Last_Switches.Table (J) (1) /= '-' then
+                        if Main = null then
+                           Main := Last_Switches.Table (J);
+
+                        else
+                           Main := null;
+                           exit;
+                        end if;
+                     end if;
+                  end loop;
+
+                  if Main /= null then
+                     Switches_Array :=
+                       Prj.Util.Value_Of
+                         (Name      => Name_Switches,
+                          In_Arrays => Element.Decl.Arrays,
+                          In_Tree   => Project_Tree);
+                     Name_Len := 0;
+                     Add_Str_To_Name_Buffer (Main.all);
+                     The_Switches := Prj.Util.Value_Of
+                       (Index     => Name_Find,
+                        Src_Index => 0,
+                        In_Array  => Switches_Array,
+                        In_Tree   => Project_Tree);
+                  end if;
+
                   if The_Switches.Kind = Prj.Undefined then
-                     Default_Switches_Array :=
+                     Switches_Array :=
                        Prj.Util.Value_Of
                          (Name      => Name_Default_Switches,
                           In_Arrays => Element.Decl.Arrays,
@@ -1847,7 +1878,7 @@ begin
                      The_Switches := Prj.Util.Value_Of
                        (Index     => Name_Ada,
                         Src_Index => 0,
-                        In_Array  => Default_Switches_Array,
+                        In_Array  => Switches_Array,
                         In_Tree   => Project_Tree);
                   end if;
                end if;

gcc/ada/par-prag.adb

@@ -1081,6 +1081,7 @@ begin
            Pragma_Convention                    |
            Pragma_Debug_Policy                  |
            Pragma_Detect_Blocking               |
+           Pragma_Dimension                     |
            Pragma_Discard_Names                 |
            Pragma_Eliminate                     |
            Pragma_Elaborate                     |

gcc/ada/sem_prag.adb

@@ -6490,6 +6490,24 @@ package body Sem_Prag is
             Check_Valid_Configuration_Pragma;
             Detect_Blocking := True;
 
+         ---------------
+         -- Dimension --
+         ---------------
+
+         when Pragma_Dimension =>
+            GNAT_Pragma;
+            Check_Arg_Count (4);
+            Check_No_Identifiers;
+            Check_Arg_Is_Local_Name (Arg1);
+
+            if not Is_Type (Arg1) then
+               Error_Pragma ("first argument for pragma% must be subtype");
+            end if;
+
+            Check_Arg_Is_Static_Expression (Arg2, Standard_Integer);
+            Check_Arg_Is_Static_Expression (Arg3, Standard_Integer);
+            Check_Arg_Is_Static_Expression (Arg4, Standard_Integer);
+
          -------------------
          -- Discard_Names --
          -------------------
@@ -12450,14 +12468,13 @@ package body Sem_Prag is
    -----------------------------------------
 
    --  This function makes use of the following static table which indicates
-   --  whether a given pragma is significant. A value of -1 in this table
-   --  indicates that the reference is significant. A value of zero indicates
-   --  than appearance as any argument is insignificant, a positive value
-   --  indicates that appearance in that parameter position is significant.
+   --  whether a given pragma is significant.
 
-   --  A value of 99 flags a special case requiring a special check (this is
-   --  used for cases not covered by this standard encoding, e.g. pragma Check
-   --  where the first argument is not significant, but the others are).
+   --  -1  indicates that references in any argument position are significant
+   --  0   indicates that appearence in any argument is not significant
+   --  +n  indicates that appearence as argument n is significant, but all
+   --      other arguments are not significant
+   --  99  special processing required (e.g. for pragma Check)
 
    Sig_Flags : constant array (Pragma_Id) of Int :=
      (Pragma_AST_Entry                     => -1,
@@ -12498,6 +12515,7 @@ package body Sem_Prag is
       Pragma_Debug                         => -1,
       Pragma_Debug_Policy                  =>  0,
       Pragma_Detect_Blocking               => -1,
+      Pragma_Dimension                     => -1,
       Pragma_Discard_Names                 =>  0,
       Pragma_Elaborate                     => -1,
       Pragma_Elaborate_All                 => -1,

gcc/ada/snames.ads-tmpl

@@ -428,6 +428,7 @@ package Snames is
    Name_CPP_Virtual                    : constant Name_Id := N + $; -- GNAT
    Name_CPP_Vtable                     : constant Name_Id := N + $; -- GNAT
    Name_Debug                          : constant Name_Id := N + $; -- GNAT
+   Name_Dimension                      : constant Name_Id := N + $; -- GNAT
    Name_Elaborate                      : constant Name_Id := N + $; -- Ada 83
    Name_Elaborate_All                  : constant Name_Id := N + $;
    Name_Elaborate_Body                 : constant Name_Id := N + $;
@@ -1494,6 +1495,7 @@ package Snames is
       Pragma_CPP_Virtual,
       Pragma_CPP_Vtable,
       Pragma_Debug,
+      Pragma_Dimension,
       Pragma_Elaborate,
       Pragma_Elaborate_All,
       Pragma_Elaborate_Body,