sem_prag.ads (Process_Compile_Time_Warning_Or_Error): New overloaded subprogram that factorizes code executed as part of the regular...

2016-10-13  Javier Miranda  <miranda@adacore.com>

	* sem_prag.ads (Process_Compile_Time_Warning_Or_Error): New
	overloaded subprogram that factorizes code executed as part
	of the regular processing of these pragmas and as part of its
	validation after invoking the backend.
	* sem_prag.adb (Process_Compile_Time_Warning_Or_Error): New
	subprogram.
	(Process_Compile_Time_Warning_Or_Error): If the
	condition is known at compile time then invoke the new overloaded
	subprogram; otherwise register the pragma in a table to validate
	it after invoking the backend.
	* sem.ads, sem.adb (Unlock): New subprogram.
	* sem_attr.adb (Analyze_Attribute [Size]): If we are processing
	pragmas Compile_Time_Warning and Compile_Time_Errors after the
	backend has been called then evaluate this attribute if 'Size
	is known at compile time.
	* gnat1drv.adb (Post_Compilation_Validation_Checks): Validate
	compile time warnings and errors.
	* sem_ch13.ads, sem_ch13.adb (Validate_Compile_Time_Warning_Error):
	New subprogram.
	(Validate_Compile_Time_Warning_Errors): New subprogram.

From-SVN: r241107

gcc/ada/ChangeLog

@@ -1,3 +1,26 @@
+2016-10-13  Javier Miranda  <miranda@adacore.com>
+
+	* sem_prag.ads (Process_Compile_Time_Warning_Or_Error): New
+	overloaded subprogram that factorizes code executed as part
+	of the regular processing of these pragmas and as part of its
+	validation after invoking the backend.
+	* sem_prag.adb (Process_Compile_Time_Warning_Or_Error): New
+	subprogram.
+	(Process_Compile_Time_Warning_Or_Error): If the
+	condition is known at compile time then invoke the new overloaded
+	subprogram; otherwise register the pragma in a table to validate
+	it after invoking the backend.
+	* sem.ads, sem.adb (Unlock): New subprogram.
+	* sem_attr.adb (Analyze_Attribute [Size]): If we are processing
+	pragmas Compile_Time_Warning and Compile_Time_Errors after the
+	backend has been called then evaluate this attribute if 'Size
+	is known at compile time.
+	* gnat1drv.adb (Post_Compilation_Validation_Checks): Validate
+	compile time warnings and errors.
+	* sem_ch13.ads, sem_ch13.adb (Validate_Compile_Time_Warning_Error):
+	New subprogram.
+	(Validate_Compile_Time_Warning_Errors): New subprogram.
+
 2016-10-13  Yannick Moy  <moy@adacore.com>
 
 	* sem_prag.adb (Analyze_Refined_Depends_In_Decl_Part): Adapt to

gcc/ada/gnat1drv.adb

@@ -871,6 +871,18 @@ procedure Gnat1drv is
 
       Checks.Validate_Alignment_Check_Warnings;
 
+      --  Validate compile time warnings and errors (using the values for size
+      --  and alignment annotated by the backend where possible). We need to
+      --  unlock temporarily these tables to reanalyze their expression.
+
+      Atree.Unlock;
+      Nlists.Unlock;
+      Sem.Unlock;
+      Sem_Ch13.Validate_Compile_Time_Warning_Errors;
+      Sem.Lock;
+      Nlists.Lock;
+      Atree.Lock;
+
       --  Validate unchecked conversions (using the values for size and
       --  alignment annotated by the backend where possible).
 

gcc/ada/sem.adb

@@ -1621,6 +1621,15 @@ package body Sem is
       return ss (Scope_Stack.Last);
    end sst;
 
+   ------------
+   -- Unlock --
+   ------------
+
+   procedure Unlock is
+   begin
+      Scope_Stack.Locked := False;
+   end Unlock;
+
    ------------------------
    -- Walk_Library_Items --
    ------------------------

gcc/ada/sem.ads

@@ -253,6 +253,11 @@ package Sem is
    --  future possibility by making it a counter. As with In_Spec_Expression,
    --  it must be recursively saved and restored for a Semantics call.
 
+   In_Compile_Time_Warning_Or_Error : Boolean := False;
+   --  Switch to indicate that we are validating a pragma Compile_Time_Warning
+   --  or Compile_Time_Error after the backend has been called (to check these
+   --  pragmas for size and alignment apropriateness).
+
    In_Default_Expr : Boolean := False;
    --  Switch to indicate that we are analyzing a default component expression.
    --  As with In_Spec_Expression, it must be recursively saved and restored
@@ -575,6 +580,9 @@ package Sem is
    procedure Lock;
    --  Lock internal tables before calling back end
 
+   procedure Unlock;
+   --  Unlock internal tables
+
    procedure Semantics (Comp_Unit : Node_Id);
    --  This procedure is called to perform semantic analysis on the specified
    --  node which is the N_Compilation_Unit node for the unit.

gcc/ada/sem_attr.adb

@@ -5746,6 +5746,22 @@ package body Sem_Attr is
          Check_Not_Incomplete_Type;
          Check_Not_CPP_Type;
          Set_Etype (N, Universal_Integer);
+
+         --  If we are processing pragmas Compile_Time_Warning and Compile_
+         --  Time_Errors after the backend has been called and this occurrence
+         --  of 'Size is known at compile time then it is safe to perform this
+         --  evaluation. Needed to perform the static evaluation of the full
+         --  boolean expression of these pragmas.
+
+         if In_Compile_Time_Warning_Or_Error
+           and then Is_Entity_Name (P)
+           and then (Is_Type (Entity (P))
+                      or else Ekind (Entity (P)) = E_Enumeration_Literal)
+           and then Size_Known_At_Compile_Time (Entity (P))
+         then
+            Rewrite (N, Make_Integer_Literal (Sloc (N), Esize (Entity (P))));
+            Analyze (N);
+         end if;
       end Size;
 
       -----------

gcc/ada/sem_ch13.adb

@@ -30,6 +30,7 @@ with Debug;    use Debug;
 with Einfo;    use Einfo;
 with Elists;   use Elists;
 with Errout;   use Errout;
+with Expander; use Expander;
 with Exp_Disp; use Exp_Disp;
 with Exp_Tss;  use Exp_Tss;
 with Exp_Util; use Exp_Util;
@@ -235,6 +236,41 @@ package body Sem_Ch13 is
    --  is True. This warning inserts the string Msg to describe the construct
    --  causing biasing.
 
+   ---------------------------------------------------
+   -- Table for Validate_Compile_Time_Warning_Error --
+   ---------------------------------------------------
+
+   --  The following table collects pragmas Compile_Time_Error and Compile_
+   --  Time_Warning for validation. Entries are made by calls to subprogram
+   --  Validate_Compile_Time_Warning_Error, and the call to the procedure
+   --  Validate_Compile_Time_Warning_Errors does the actual error checking
+   --  and posting of warning and error messages. The reason for this delayed
+   --  processing is to take advantage of back-annotations of attributes size
+   --  and alignment values performed by the back end.
+
+   --  Note: the reason we store a Source_Ptr value instead of a Node_Id is
+   --  that by the time Validate_Unchecked_Conversions is called, Sprint will
+   --  already have modified all Sloc values if the -gnatD option is set.
+
+   type CTWE_Entry is record
+      Eloc  : Source_Ptr;
+      --  Source location used in warnings and error messages
+
+      Prag  : Node_Id;
+      --  Pragma Compile_Time_Error or Compile_Time_Warning
+
+      Scope : Node_Id;
+      --  The scope which encloses the pragma
+   end record;
+
+   package Compile_Time_Warnings_Errors is new Table.Table (
+     Table_Component_Type => CTWE_Entry,
+     Table_Index_Type     => Int,
+     Table_Low_Bound      => 1,
+     Table_Initial        => 50,
+     Table_Increment      => 200,
+     Table_Name           => "Compile_Time_Warnings_Errors");
+
    ----------------------------------------------
    -- Table for Validate_Unchecked_Conversions --
    ----------------------------------------------
@@ -11405,6 +11441,7 @@ package body Sem_Ch13 is
    procedure Initialize is
    begin
       Address_Clause_Checks.Init;
+      Compile_Time_Warnings_Errors.Init;
       Unchecked_Conversions.Init;
 
       if AAMP_On_Target then
@@ -13327,6 +13364,79 @@ package body Sem_Ch13 is
       end loop;
    end Validate_Address_Clauses;
 
+   -----------------------------------------
+   -- Validate_Compile_Time_Warning_Error --
+   -----------------------------------------
+
+   procedure Validate_Compile_Time_Warning_Error (N : Node_Id) is
+   begin
+      Compile_Time_Warnings_Errors.Append
+        (New_Val => CTWE_Entry'(Eloc  => Sloc (N),
+                                Scope => Current_Scope,
+                                Prag  => N));
+   end Validate_Compile_Time_Warning_Error;
+
+   ------------------------------------------
+   -- Validate_Compile_Time_Warning_Errors --
+   ------------------------------------------
+
+   procedure Validate_Compile_Time_Warning_Errors is
+      procedure Set_Scope (S : Entity_Id);
+      --  Install all enclosing scopes of S along with S itself
+
+      procedure Unset_Scope (S : Entity_Id);
+      --  Uninstall all enclosing scopes of S along with S itself
+
+      ---------------
+      -- Set_Scope --
+      ---------------
+
+      procedure Set_Scope (S : Entity_Id) is
+      begin
+         if S /= Standard_Standard then
+            Set_Scope (Scope (S));
+         end if;
+
+         Push_Scope (S);
+      end Set_Scope;
+
+      -----------------
+      -- Unset_Scope --
+      -----------------
+
+      procedure Unset_Scope (S : Entity_Id) is
+      begin
+         if S /= Standard_Standard then
+            Unset_Scope (Scope (S));
+         end if;
+
+         Pop_Scope;
+      end Unset_Scope;
+
+   --  Start of processing for Validate_Compile_Time_Warning_Errors
+
+   begin
+      Expander_Mode_Save_And_Set (False);
+      In_Compile_Time_Warning_Or_Error := True;
+
+      for N in Compile_Time_Warnings_Errors.First ..
+               Compile_Time_Warnings_Errors.Last
+      loop
+         declare
+            T : CTWE_Entry renames Compile_Time_Warnings_Errors.Table (N);
+
+         begin
+            Set_Scope (T.Scope);
+            Reset_Analyzed_Flags (T.Prag);
+            Process_Compile_Time_Warning_Or_Error (T.Prag, T.Eloc);
+            Unset_Scope (T.Scope);
+         end;
+      end loop;
+
+      In_Compile_Time_Warning_Or_Error := False;
+      Expander_Mode_Restore;
+   end Validate_Compile_Time_Warning_Errors;
+
    ---------------------------
    -- Validate_Independence --
    ---------------------------

gcc/ada/sem_ch13.ads

@@ -188,6 +188,18 @@ package Sem_Ch13 is
    --  change. A False result is possible only for array, enumeration or
    --  record types.
 
+   procedure Validate_Compile_Time_Warning_Error (N : Node_Id);
+   --  N is a pragma Compile_Time_Error or Compile_Warning_Error whose boolean
+   --  expression is not known at compile time. This procedure makes an entry
+   --  in a table. The actual checking is performed by Validate_Compile_Time_
+   --  Warning_Errors which is invoked after calling the backend.
+
+   procedure Validate_Compile_Time_Warning_Errors;
+   --  This routine is called after calling the backend to validate pragmas
+   --  Compile_Time_Error and Compile_Time_Warning for size and alignment
+   --  appropriateness. The reason it is called that late is to take advantage
+   --  of any back-annotation of size and alignment performed by the backend.
+
    procedure Validate_Unchecked_Conversion
      (N        : Node_Id;
       Act_Unit : Entity_Id);

gcc/ada/sem_prag.adb

@@ -7024,94 +7024,9 @@ package body Sem_Prag is
          Analyze_And_Resolve (Arg1x, Standard_Boolean);
 
          if Compile_Time_Known_Value (Arg1x) then
-            if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
+            Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
-               declare
+         else
-                  Str   : constant String_Id :=
+            Sem_Ch13.Validate_Compile_Time_Warning_Error (N);
-                            Strval (Get_Pragma_Arg (Arg2));
-                  Len   : constant Nat := String_Length (Str);
-                  Cont  : Boolean;
-                  Ptr   : Nat;
-                  CC    : Char_Code;
-                  C     : Character;
-                  Cent  : constant Entity_Id :=
-                            Cunit_Entity (Current_Sem_Unit);
-
-                  Force : constant Boolean :=
-                            Prag_Id = Pragma_Compile_Time_Warning
-                              and then
-                                Is_Spec_Name (Unit_Name (Current_Sem_Unit))
-                              and then (Ekind (Cent) /= E_Package
-                                         or else not In_Private_Part (Cent));
-                  --  Set True if this is the warning case, and we are in the
-                  --  visible part of a package spec, or in a subprogram spec,
-                  --  in which case we want to force the client to see the
-                  --  warning, even though it is not in the main unit.
-
-               begin
-                  --  Loop through segments of message separated by line feeds.
-                  --  We output these segments as separate messages with
-                  --  continuation marks for all but the first.
-
-                  Cont := False;
-                  Ptr := 1;
-                  loop
-                     Error_Msg_Strlen := 0;
-
-                     --  Loop to copy characters from argument to error message
-                     --  string buffer.
-
-                     loop
-                        exit when Ptr > Len;
-                        CC := Get_String_Char (Str, Ptr);
-                        Ptr := Ptr + 1;
-
-                        --  Ignore wide chars ??? else store character
-
-                        if In_Character_Range (CC) then
-                           C := Get_Character (CC);
-                           exit when C = ASCII.LF;
-                           Error_Msg_Strlen := Error_Msg_Strlen + 1;
-                           Error_Msg_String (Error_Msg_Strlen) := C;
-                        end if;
-                     end loop;
-
-                     --  Here with one line ready to go
-
-                     Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
-
-                     --  If this is a warning in a spec, then we want clients
-                     --  to see the warning, so mark the message with the
-                     --  special sequence !! to force the warning. In the case
-                     --  of a package spec, we do not force this if we are in
-                     --  the private part of the spec.
-
-                     if Force then
-                        if Cont = False then
-                           Error_Msg_N ("<<~!!", Arg1);
-                           Cont := True;
-                        else
-                           Error_Msg_N ("\<<~!!", Arg1);
-                        end if;
-
-                     --  Error, rather than warning, or in a body, so we do not
-                     --  need to force visibility for client (error will be
-                     --  output in any case, and this is the situation in which
-                     --  we do not want a client to get a warning, since the
-                     --  warning is in the body or the spec private part).
-
-                     else
-                        if Cont = False then
-                           Error_Msg_N ("<<~", Arg1);
-                           Cont := True;
-                        else
-                           Error_Msg_N ("\<<~", Arg1);
-                        end if;
-                     end if;
-
-                     exit when Ptr > Len;
-                  end loop;
-               end;
-            end if;
          end if;
       end Process_Compile_Time_Warning_Or_Error;
 
@@ -29075,6 +28990,113 @@ package body Sem_Prag is
 
    end Process_Compilation_Unit_Pragmas;
 
+   -------------------------------------------
+   -- Process_Compile_Time_Warning_Or_Error --
+   -------------------------------------------
+
+   procedure Process_Compile_Time_Warning_Or_Error
+     (N     : Node_Id;
+      Eloc  : Source_Ptr)
+   is
+      Arg1  : constant Node_Id := First (Pragma_Argument_Associations (N));
+      Arg1x : constant Node_Id := Get_Pragma_Arg (Arg1);
+      Arg2  : constant Node_Id := Next (Arg1);
+
+   begin
+      Analyze_And_Resolve (Arg1x, Standard_Boolean);
+
+      if Compile_Time_Known_Value (Arg1x) then
+         if Is_True (Expr_Value (Arg1x)) then
+            declare
+               Cent    : constant Entity_Id := Cunit_Entity (Current_Sem_Unit);
+               Pname   : constant Name_Id   := Pragma_Name (N);
+               Prag_Id : constant Pragma_Id := Get_Pragma_Id (Pname);
+               Str     : constant String_Id := Strval (Get_Pragma_Arg (Arg2));
+               Str_Len : constant Nat       := String_Length (Str);
+
+               Force : constant Boolean :=
+                         Prag_Id = Pragma_Compile_Time_Warning
+                           and then Is_Spec_Name (Unit_Name (Current_Sem_Unit))
+                           and then (Ekind (Cent) /= E_Package
+                                      or else not In_Private_Part (Cent));
+               --  Set True if this is the warning case, and we are in the
+               --  visible part of a package spec, or in a subprogram spec,
+               --  in which case we want to force the client to see the
+               --  warning, even though it is not in the main unit.
+
+               C    : Character;
+               CC   : Char_Code;
+               Cont : Boolean;
+               Ptr  : Nat;
+
+            begin
+               --  Loop through segments of message separated by line feeds.
+               --  We output these segments as separate messages with
+               --  continuation marks for all but the first.
+
+               Cont := False;
+               Ptr  := 1;
+               loop
+                  Error_Msg_Strlen := 0;
+
+                  --  Loop to copy characters from argument to error message
+                  --  string buffer.
+
+                  loop
+                     exit when Ptr > Str_Len;
+                     CC := Get_String_Char (Str, Ptr);
+                     Ptr := Ptr + 1;
+
+                     --  Ignore wide chars ??? else store character
+
+                     if In_Character_Range (CC) then
+                        C := Get_Character (CC);
+                        exit when C = ASCII.LF;
+                        Error_Msg_Strlen := Error_Msg_Strlen + 1;
+                        Error_Msg_String (Error_Msg_Strlen) := C;
+                     end if;
+                  end loop;
+
+                  --  Here with one line ready to go
+
+                  Error_Msg_Warn := Prag_Id = Pragma_Compile_Time_Warning;
+
+                  --  If this is a warning in a spec, then we want clients
+                  --  to see the warning, so mark the message with the
+                  --  special sequence !! to force the warning. In the case
+                  --  of a package spec, we do not force this if we are in
+                  --  the private part of the spec.
+
+                  if Force then
+                     if Cont = False then
+                        Error_Msg ("<<~!!", Eloc);
+                        Cont := True;
+                     else
+                        Error_Msg ("\<<~!!", Eloc);
+                     end if;
+
+                  --  Error, rather than warning, or in a body, so we do not
+                  --  need to force visibility for client (error will be
+                  --  output in any case, and this is the situation in which
+                  --  we do not want a client to get a warning, since the
+                  --  warning is in the body or the spec private part).
+
+                  else
+                     if Cont = False then
+                        Error_Msg ("<<~", Eloc);
+                        Cont := True;
+                     else
+                        Error_Msg ("\<<~", Eloc);
+                     end if;
+                  end if;
+
+                  exit when Ptr > Str_Len;
+               end loop;
+            end;
+         end if;
+      end if;
+   end Process_Compile_Time_Warning_Or_Error;
+
    ------------------------------------
    -- Record_Possible_Body_Reference --
    ------------------------------------

gcc/ada/sem_prag.ads

@@ -485,6 +485,14 @@ package Sem_Prag is
    --  Name_uInvariant, and Name_uType_Invariant (_Pre, _Post, _Invariant,
    --  and _Type_Invariant).
 
+   procedure Process_Compile_Time_Warning_Or_Error
+     (N    : Node_Id;
+      Eloc : Source_Ptr);
+   --  Common processing for Compile_Time_Error and Compile_Time_Warning of
+   --  pragma N. Called when the pragma is processed as part of its regular
+   --  analysis but also called after calling the backend to validate these
+   --  pragmas for size and alignment apropriateness.
+
    procedure Process_Compilation_Unit_Pragmas (N : Node_Id);
    --  Called at the start of processing compilation unit N to deal with any
    --  special issues regarding pragmas. In particular, we have to deal with