+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
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).
return ss (Scope_Stack.Last);
end sst;
+ ------------
+ -- Unlock --
+ ------------
+
+ procedure Unlock is
+ begin
+ Scope_Stack.Locked := False;
+ end Unlock;
+
------------------------
-- Walk_Library_Items --
------------------------
-- 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
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.
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;
-----------
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;
-- 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 --
----------------------------------------------
procedure Initialize is
begin
Address_Clause_Checks.Init;
+ Compile_Time_Warnings_Errors.Init;
Unchecked_Conversions.Init;
if AAMP_On_Target then
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 --
---------------------------
-- 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);
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;
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 --
------------------------------------
-- 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
projects / gcc.git / commitdiff