ali.adb: Set Allocator_In_Body if AB parameter present on M line

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

	* ali.adb: Set Allocator_In_Body if AB parameter present on M line
	* ali.ads (Allocator_In_Body): New flag
	* bcheck.adb (Check_Consistent_Restrictions): Handle case of main
	program violating No_Allocators_After_Elaboration restriction.
	* gnatbind.adb (No_Restriction_List): Add entries for
	No_Anonymous_Allocators, and No_Allocators_After_Elaboration.
	* lib-load.adb: Initialize Has_Allocator flag
	* lib-writ.adb: Initialize Has_Allocator flag
	(M_Parameters): Set AB switch if Has_Allocator flag set
	* lib-writ.ads: Document AB flag on M line
	* lib.adb (Has_Allocator): New function
	(Set_Has_Allocator): New procedure
	* lib.ads (Has_Allocator): New function
	(Set_Has_Allocator): New procedure
	(Has_Allocator): New flag in Unit_Record
	* sem_ch4.adb (Analyze_Allocator): Add processing for
	No_Allocators_After_Elaboration.

From-SVN: r165171

11 files changed, 153 insertions, 15 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index eb440cec55a..20901345741 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,23 @@
+2010-10-08  Robert Dewar  <dewar@adacore.com>
+
+	* ali.adb: Set Allocator_In_Body if AB parameter present on M line
+	* ali.ads (Allocator_In_Body): New flag
+	* bcheck.adb (Check_Consistent_Restrictions): Handle case of main
+	program violating No_Allocators_After_Elaboration restriction.
+	* gnatbind.adb (No_Restriction_List): Add entries for
+	No_Anonymous_Allocators, and No_Allocators_After_Elaboration.
+	* lib-load.adb: Initialize Has_Allocator flag
+	* lib-writ.adb: Initialize Has_Allocator flag
+	(M_Parameters): Set AB switch if Has_Allocator flag set
+	* lib-writ.ads: Document AB flag on M line
+	* lib.adb (Has_Allocator): New function
+	(Set_Has_Allocator): New procedure
+	* lib.ads (Has_Allocator): New function
+	(Set_Has_Allocator): New procedure
+	(Has_Allocator): New flag in Unit_Record
+	* sem_ch4.adb (Analyze_Allocator): Add processing for
+	No_Allocators_After_Elaboration.
+
 2010-10-08  Geert Bosch  <bosch@adacore.com>
 
 	* a-textio.adb (Get_Line): Rewrite to use fgets instead of fgetc.
diff --git a/gcc/ada/ali.adb b/gcc/ada/ali.adb
index eb45dcaca50..bf7ace87a45 100644
--- a/gcc/ada/ali.adb
+++ b/gcc/ada/ali.adb
@@ -828,6 +828,7 @@ package body ALI is
         Sfile                      => No_File,
         Task_Dispatching_Policy    => ' ',
         Time_Slice_Value           => -1,
+        Allocator_In_Body          => False,
         WC_Encoding                => 'b',
         Unit_Exception_Table       => False,
         Ver                        => (others => ' '),
@@ -910,6 +911,14 @@ package body ALI is
 
                Skip_Space;
 
+               if Nextc = 'A' then
+                  P := P + 1;
+                  Checkc ('B');
+                  ALIs.Table (Id).Allocator_In_Body := True;
+               end if;
+
+               Skip_Space;
+
                Checkc ('W');
                Checkc ('=');
                ALIs.Table (Id).WC_Encoding := Getc;
diff --git a/gcc/ada/ali.ads b/gcc/ada/ali.ads
index 74aeaed026d..062652c4820 100644
--- a/gcc/ada/ali.ads
+++ b/gcc/ada/ali.ads
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -136,6 +136,10 @@ package ALI is
       --  line. A value of -1 indicates that no T=xxx parameter was found, or
       --  no M line was present. Not set if 'M' appears in Ignore_Lines.
 
+      Allocator_In_Body : Boolean;
+      --  Set True if an AB switch appears on the main program line. False
+      --  if no M line, or AB not present, or 'M appears in Ignore_Lines.
+
       WC_Encoding : Character;
       --  Wide character encoding if main procedure. Otherwise not relevant.
       --  Not set if 'M' appears in Ignore_Lines.
diff --git a/gcc/ada/bcheck.adb b/gcc/ada/bcheck.adb
index 084ce199dda..796627e0d52 100644
--- a/gcc/ada/bcheck.adb
+++ b/gcc/ada/bcheck.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, 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- --
@@ -854,6 +854,22 @@ package body Bcheck is
    --  Start of processing for Check_Consistent_Restrictions
 
    begin
+      --  A special test, if we have a main program, then if it has an
+      --  allocator in the body, this is considered to be a violation of
+      --  the restriction No_Allocators_After_Elaboration. We just mark
+      --  this restriction and then the normal circuit will flag it.
+
+      if Bind_Main_Program
+        and then ALIs.Table (ALIs.First).Main_Program /= None
+        and then not No_Main_Subprogram
+        and then ALIs.Table (ALIs.First).Allocator_In_Body
+      then
+         Cumulative_Restrictions.Violated
+           (No_Allocators_After_Elaboration) := True;
+         ALIs.Table (ALIs.First).Restrictions.Violated
+           (No_Allocators_After_Elaboration) := True;
+      end if;
+
       --  Loop through all restriction violations
 
       for R in All_Restrictions loop
diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb
index 9285aa96264..de3084f0267 100644
--- a/gcc/ada/gnatbind.adb
+++ b/gcc/ada/gnatbind.adb
@@ -143,34 +143,40 @@ procedure Gnatbind is
       --  should not be listed.
 
       No_Restriction_List : constant array (All_Restrictions) of Boolean :=
-        (No_Exception_Propagation => True,
+        (No_Allocators_After_Elaboration => True,
+         --  This involves run-time conditions not checkable at compile time
+
+         No_Anonymous_Allocators         => True,
+         --  Premature, since we have not implemented this yet
+
+         No_Exception_Propagation        => True,
          --  Modifies code resulting in different exception semantics
 
-         No_Exceptions            => True,
+         No_Exceptions                   => True,
          --  Has unexpected Suppress (All_Checks) effect
 
-         No_Implicit_Conditionals => True,
+         No_Implicit_Conditionals        => True,
          --  This could modify and pessimize generated code
 
-         No_Implicit_Dynamic_Code => True,
+         No_Implicit_Dynamic_Code        => True,
          --  This could modify and pessimize generated code
 
-         No_Implicit_Loops        => True,
+         No_Implicit_Loops               => True,
          --  This could modify and pessimize generated code
 
-         No_Recursion             => True,
+         No_Recursion                    => True,
          --  Not checkable at compile time
 
-         No_Reentrancy            => True,
+         No_Reentrancy                   => True,
          --  Not checkable at compile time
 
-         Max_Entry_Queue_Length    => True,
+         Max_Entry_Queue_Length           => True,
          --  Not checkable at compile time
 
-         Max_Storage_At_Blocking  => True,
+         Max_Storage_At_Blocking         => True,
          --  Not checkable at compile time
 
-         others => False);
+         others                          => False);
 
       Additional_Restrictions_Listed : Boolean := False;
       --  Set True if we have listed header for restrictions
diff --git a/gcc/ada/lib-load.adb b/gcc/ada/lib-load.adb
index 4b39c0a4913..328bbeb6d03 100644
--- a/gcc/ada/lib-load.adb
+++ b/gcc/ada/lib-load.adb
@@ -214,6 +214,7 @@ package body Lib.Load is
         Expected_Unit    => Spec_Name,
         Fatal_Error      => True,
         Generate_Code    => False,
+        Has_Allocator    => False,
         Has_RACW         => False,
         Is_Compiler_Unit => False,
         Ident_String     => Empty,
@@ -318,6 +319,7 @@ package body Lib.Load is
            Expected_Unit    => No_Unit_Name,
            Fatal_Error      => False,
            Generate_Code    => False,
+           Has_Allocator    => False,
            Has_RACW         => False,
            Is_Compiler_Unit => False,
            Ident_String     => Empty,
@@ -647,6 +649,7 @@ package body Lib.Load is
               Expected_Unit    => Uname_Actual,
               Fatal_Error      => False,
               Generate_Code    => False,
+              Has_Allocator    => False,
               Has_RACW         => False,
               Is_Compiler_Unit => False,
               Ident_String     => Empty,
diff --git a/gcc/ada/lib-writ.adb b/gcc/ada/lib-writ.adb
index 8912dfa48e9..b7bc2cfcf59 100644
--- a/gcc/ada/lib-writ.adb
+++ b/gcc/ada/lib-writ.adb
@@ -80,6 +80,7 @@ package body Lib.Writ is
          Dynamic_Elab     => False,
          Fatal_Error      => False,
          Generate_Code    => False,
+         Has_Allocator    => False,
          Has_RACW         => False,
          Is_Compiler_Unit => False,
          Ident_String     => Empty,
@@ -135,6 +136,7 @@ package body Lib.Writ is
         Dynamic_Elab     => False,
         Fatal_Error      => False,
         Generate_Code    => False,
+        Has_Allocator    => False,
         Has_RACW         => False,
         Is_Compiler_Unit => False,
         Ident_String     => Empty,
@@ -925,6 +927,10 @@ package body Lib.Writ is
                Write_Info_Nat (Opt.Time_Slice_Value);
             end if;
 
+            if Has_Allocator (Main_Unit) then
+               Write_Info_Str (" AB");
+            end if;
+
             Write_Info_Str (" W=");
             Write_Info_Char
               (WC_Encoding_Letters (Wide_Character_Encoding_Method));
diff --git a/gcc/ada/lib-writ.ads b/gcc/ada/lib-writ.ads
index 54514325229..b3ea32d1282 100644
--- a/gcc/ada/lib-writ.ads
+++ b/gcc/ada/lib-writ.ads
@@ -116,7 +116,7 @@ package Lib.Writ is
    --  -- M  Main Program --
    --  ---------------------
 
-   --    M type [priority] [T=time-slice] W=?
+   --    M type [priority] [T=time-slice] [AB] W=?
 
    --      This line appears only if the main unit for this file is suitable
    --      for use as a main program. The parameters are:
@@ -141,6 +141,15 @@ package Lib.Writ is
    --          milliseconds. The actual significance of this parameter is
    --          target dependent.
 
+   --        AB
+
+   --          Present if there is an allocator in the body of the procedure
+   --          after the BEGIN. This will be a violation of the restriction
+   --          No_Allocators_After_Elaboration if it is present, and this
+   --          unit is used as a main program (only the binder can find the
+   --          violation, since only the binder knows the main program).
+   --
+
    --        W=?
 
    --          This parameter indicates the wide character encoding method used
diff --git a/gcc/ada/lib.adb b/gcc/ada/lib.adb
index 893c4cfbbb2..90577e481af 100644
--- a/gcc/ada/lib.adb
+++ b/gcc/ada/lib.adb
@@ -113,6 +113,11 @@ package body Lib is
       return Units.Table (U).Generate_Code;
    end Generate_Code;
 
+   function Has_Allocator (U : Unit_Number_Type) return Boolean is
+   begin
+      return Units.Table (U).Has_Allocator;
+   end Has_Allocator;
+
    function Has_RACW (U : Unit_Number_Type) return Boolean is
    begin
       return Units.Table (U).Has_RACW;
@@ -198,6 +203,11 @@ package body Lib is
       Units.Table (U).Generate_Code := B;
    end Set_Generate_Code;
 
+   procedure Set_Has_Allocator (U : Unit_Number_Type; B : Boolean := True) is
+   begin
+      Units.Table (U).Has_Allocator := B;
+   end Set_Has_Allocator;
+
    procedure Set_Has_RACW (U : Unit_Number_Type; B : Boolean := True) is
    begin
       Units.Table (U).Has_RACW := B;
diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads
index 28e2ec064cd..13962528e3e 100644
--- a/gcc/ada/lib.ads
+++ b/gcc/ada/lib.ads
@@ -357,6 +357,10 @@ package Lib is
    --      that the default priority is to be used (and is also used for
    --      entries that do not correspond to possible main programs).
 
+   --    Has_Allocator
+   --      This flag is set if a subprogram unit has an allocator after the
+   --      BEGIN (it is used to set the AB flag in the M ALI line).
+
    --    OA_Setting
    --      This is a character field containing L if Optimize_Alignment mode
    --      was set locally, and O/T/S for Off/Time/Space default if not.
@@ -397,6 +401,7 @@ package Lib is
    function Fatal_Error      (U : Unit_Number_Type) return Boolean;
    function Generate_Code    (U : Unit_Number_Type) return Boolean;
    function Ident_String     (U : Unit_Number_Type) return Node_Id;
+   function Has_Allocator    (U : Unit_Number_Type) return Boolean;
    function Has_RACW         (U : Unit_Number_Type) return Boolean;
    function Is_Compiler_Unit (U : Unit_Number_Type) return Boolean;
    function Loading          (U : Unit_Number_Type) return Boolean;
@@ -415,6 +420,7 @@ package Lib is
    procedure Set_Fatal_Error      (U : Unit_Number_Type; B : Boolean := True);
    procedure Set_Generate_Code    (U : Unit_Number_Type; B : Boolean := True);
    procedure Set_Has_RACW         (U : Unit_Number_Type; B : Boolean := True);
+   procedure Set_Has_Allocator    (U : Unit_Number_Type; B : Boolean := True);
    procedure Set_Is_Compiler_Unit (U : Unit_Number_Type; B : Boolean := True);
    procedure Set_Ident_String     (U : Unit_Number_Type; N : Node_Id);
    procedure Set_Loading          (U : Unit_Number_Type; B : Boolean := True);
@@ -653,6 +659,7 @@ private
    pragma Inline (Dependency_Num);
    pragma Inline (Fatal_Error);
    pragma Inline (Generate_Code);
+   pragma Inline (Has_Allocator);
    pragma Inline (Has_RACW);
    pragma Inline (Is_Compiler_Unit);
    pragma Inline (Increment_Serial_Number);
@@ -664,6 +671,7 @@ private
    pragma Inline (Set_Cunit_Entity);
    pragma Inline (Set_Fatal_Error);
    pragma Inline (Set_Generate_Code);
+   pragma Inline (Set_Has_Allocator);
    pragma Inline (Set_Has_RACW);
    pragma Inline (Set_Loading);
    pragma Inline (Set_Main_Priority);
@@ -693,6 +701,7 @@ private
       Is_Compiler_Unit : Boolean;
       Dynamic_Elab     : Boolean;
       Loading          : Boolean;
+      Has_Allocator    : Boolean;
       OA_Setting       : Character;
    end record;
 
@@ -720,7 +729,8 @@ private
       Dynamic_Elab     at 55 range 0 ..  7;
       Is_Compiler_Unit at 56 range 0 ..  7;
       OA_Setting       at 57 range 0 ..  7;
-      Loading          at 58 range 0 .. 15;
+      Loading          at 58 range 0 ..  7;
+      Has_Allocator    at 59 range 0 ..  7;
    end record;
 
    for Unit_Record'Size use 60 * 8;
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index 154b5d3376d..183de2d36ed 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -364,15 +364,60 @@ package body Sem_Ch4 is
       E        : Node_Id             := Expression (N);
       Acc_Type : Entity_Id;
       Type_Id  : Entity_Id;
+      P        : Node_Id;
+      C        : Node_Id;
 
    begin
+      --  Deal with allocator restrictions
+
       --  In accordance with H.4(7), the No_Allocators restriction only applies
-      --  to user-written allocators.
+      --  to user-written allocators. The same consideration applies to the
+      --  No_Allocators_Before_Elaboration restriction.
 
       if Comes_From_Source (N) then
          Check_Restriction (No_Allocators, N);
+
+         --  Processing for No_Allocators_After_Elaboration, loop to look at
+         --  enclosing context, checking task case and main subprogram case.
+
+         C := N;
+         P := Parent (C);
+         while Present (P) loop
+
+            --  In both cases we need a handled sequence of statements, where
+            --  the occurrence of the allocator is within the statements.
+
+            if Nkind (P) = N_Handled_Sequence_Of_Statements
+              and then Is_List_Member (C)
+              and then List_Containing (C) = Statements (P)
+            then
+               --  Check for allocator within task body, this is a definite
+               --  violation of No_Allocators_After_Elaboration we can detect.
+
+               if Nkind (Original_Node (Parent (P))) = N_Task_Body then
+                  Check_Restriction (No_Allocators_After_Elaboration, N);
+                  exit;
+               end if;
+
+               --  The other case is appearence in a subprogram body. This may
+               --  be a violation if this is a library level subprogram, and it
+               --  turns out to be used as the main program, but only the
+               --  binder knows that, so just record the occurrence.
+
+               if Nkind (Original_Node (Parent (P))) = N_Subprogram_Body
+                 and then Nkind (Parent (Parent (P))) = N_Compilation_Unit
+               then
+                  Set_Has_Allocator (Current_Sem_Unit);
+               end if;
+            end if;
+
+            C := P;
+            P := Parent (C);
+         end loop;
       end if;
 
+      --  Analyze the allocator
+
       if Nkind (E) = N_Qualified_Expression then
          Acc_Type := Create_Itype (E_Allocator_Type, N);
          Set_Etype (Acc_Type, Acc_Type);