From a946a5c38d46ae99653649aafadf8f020defaa5d Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Thu, 13 Oct 2016 12:12:18 +0000 Subject: [PATCH] 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 * 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 | 23 +++++ gcc/ada/gnat1drv.adb | 12 +++ gcc/ada/sem.adb | 9 ++ gcc/ada/sem.ads | 8 ++ gcc/ada/sem_attr.adb | 16 ++++ gcc/ada/sem_ch13.adb | 110 ++++++++++++++++++++++++ gcc/ada/sem_ch13.ads | 12 +++ gcc/ada/sem_prag.adb | 198 ++++++++++++++++++++++++------------------- gcc/ada/sem_prag.ads | 8 ++ 9 files changed, 308 insertions(+), 88 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 31404026c79..0d68ec6511e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,26 @@ +2016-10-13 Javier Miranda + + * 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 * sem_prag.adb (Analyze_Refined_Depends_In_Decl_Part): Adapt to diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index fa08414652c..929bfcc316d 100644 --- a/gcc/ada/gnat1drv.adb +++ b/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). diff --git a/gcc/ada/sem.adb b/gcc/ada/sem.adb index 1b1720d3c7b..f904a506c01 100644 --- a/gcc/ada/sem.adb +++ b/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 -- ------------------------ diff --git a/gcc/ada/sem.ads b/gcc/ada/sem.ads index f9c2dadabf3..23b78fcb1db 100644 --- a/gcc/ada/sem.ads +++ b/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. diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index b457aa45114..0190bd7ebfe 100644 --- a/gcc/ada/sem_attr.adb +++ b/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; ----------- diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 863777914cc..bff49e6430b 100644 --- a/gcc/ada/sem_ch13.adb +++ b/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 -- --------------------------- diff --git a/gcc/ada/sem_ch13.ads b/gcc/ada/sem_ch13.ads index e3ee2117f35..af056bebe39 100644 --- a/gcc/ada/sem_ch13.ads +++ b/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); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4128216e01a..21e4c7fa15e 100644 --- a/gcc/ada/sem_prag.adb +++ b/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 -- ------------------------------------ diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index c442d55246a..ae456f52960 100644 --- a/gcc/ada/sem_prag.ads +++ b/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 -- 2.30.2