===================================================================
@@ -7024,94 +7024,9 @@
Analyze_And_Resolve (Arg1x, Standard_Boolean);
if Compile_Time_Known_Value (Arg1x) then
- if Is_True (Expr_Value (Get_Pragma_Arg (Arg1))) then
- declare
- Str : constant String_Id :=
- 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;
+ Process_Compile_Time_Warning_Or_Error (N, Sloc (Arg1));
+ else
+ Sem_Ch13.Validate_Compile_Time_Warning_Error (N);
end if;
end Process_Compile_Time_Warning_Or_Error;
@@ -29075,6 +28990,113 @@
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 --
------------------------------------
===================================================================
@@ -485,6 +485,14 @@
-- 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
===================================================================
@@ -1621,6 +1621,15 @@
return ss (Scope_Stack.Last);
end sst;
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock is
+ begin
+ Scope_Stack.Locked := False;
+ end Unlock;
+
------------------------
-- Walk_Library_Items --
------------------------
===================================================================
@@ -253,6 +253,11 @@
-- 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 @@
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.
===================================================================
@@ -5746,6 +5746,22 @@
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;
-----------
===================================================================
@@ -871,6 +871,18 @@
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).
===================================================================
@@ -30,6 +30,7 @@
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 @@
-- 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 @@
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 @@
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 --
---------------------------
===================================================================
@@ -188,6 +188,18 @@
-- 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);
Extend the functionality of pragmas Compile_Time_Warning and Compile_Time_ Error to use statically known values of attributes 'Size and 'Alignment. For example: procedure do_test is generic type ParamType is private; package Gen is pragma Compile_Time_Error (ParamType'Size = 0, "ParamType must not be null"); end; type NR is null record; package Inst is new Gen (NR); begin null; end do_test; Command: gcc -c do_test.adb Output: do_test.adb:10:04: instantiation error at line 5 do_test.adb:10:04: ParamType must not be null Tested on x86_64-pc-linux-gnu, committed on trunk 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.