Skip to content

R
riscv-gcc-1
Commit a946a5c3 by Javier Miranda Committed by Arnaud Charlet
Options

sem_prag.ads (Process_Compile_Time_Warning_Or_Error): New overloaded subprogram… 

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
parent c877ae8d
Showing with 308 additions and 88 deletions
gcc/ada/ChangeLog
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
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 @@ 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
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment