From patchwork Thu Oct 13 12:12:25 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 681774 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3svqPB6g2tz9sD6 for ; Thu, 13 Oct 2016 23:12:46 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=uvrQZBSq; dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; q=dns; s=default; b=rfCpyjyJo8soAjpfTKmelPC/YxEK4QUD2QUQnnJCAhgd2Y9zd5 QW8l6saau9lA/6sF0Skhrj1y5HJpgzBCbdTt15ahM67qh+iFR4aDhmr70PsySRbn tZyDQ8BKf9mD1u7jSo7OC/rzuCA7WA8r08mpXzTlB9nQuao4ozp578oKg= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:mime-version:content-type; s= default; bh=YZWIgvBiWGS/NsTAjkno1ldfwXA=; b=uvrQZBSqtHGbeqz2/diy 79ucSPNWdKCeEYshk2dk//3z4Rvwr3BTgfchsRt0be7H9FgAwbQYIuISV7+QU78P q3i8ByvnmM7it/0Pc3Fh60PhmghqOYSvG0YyLWyf21Mf/psvwz2UxxdMeSkh+obM gc/D85ENZAvc2H7Z64BAX9s= Received: (qmail 114971 invoked by alias); 13 Oct 2016 12:12:38 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 114056 invoked by uid 89); 13 Oct 2016 12:12:37 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=1.6 required=5.0 tests=AWL, BAYES_50, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=no version=3.3.2 spammy=javier, Javier, cent, Cent X-HELO: rock.gnat.com Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with ESMTP; Thu, 13 Oct 2016 12:12:27 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id B7D35116AC5; Thu, 13 Oct 2016 08:12:25 -0400 (EDT) Received: from rock.gnat.com ([127.0.0.1]) by localhost (rock.gnat.com [127.0.0.1]) (amavisd-new, port 10024) with LMTP id IbWqfVqqv6Gd; Thu, 13 Oct 2016 08:12:25 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id A6553116AA2; Thu, 13 Oct 2016 08:12:25 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 9FFFD409; Thu, 13 Oct 2016 08:12:25 -0400 (EDT) Date: Thu, 13 Oct 2016 08:12:25 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] Pragmas Compile_Time_Error and Compile_Time_Warning and 'Size Message-ID: <20161013121225.GA84700@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) 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 * 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. Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 241106) +++ sem_prag.adb (working copy) @@ -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 -- ------------------------------------ Index: sem_prag.ads =================================================================== --- sem_prag.ads (revision 241105) +++ sem_prag.ads (working copy) @@ -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 Index: sem.adb =================================================================== --- sem.adb (revision 241105) +++ sem.adb (working copy) @@ -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 -- ------------------------ Index: sem.ads =================================================================== --- sem.ads (revision 241105) +++ sem.ads (working copy) @@ -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. Index: sem_attr.adb =================================================================== --- sem_attr.adb (revision 241105) +++ sem_attr.adb (working copy) @@ -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; ----------- Index: gnat1drv.adb =================================================================== --- gnat1drv.adb (revision 241105) +++ gnat1drv.adb (working copy) @@ -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). Index: sem_ch13.adb =================================================================== --- sem_ch13.adb (revision 241106) +++ sem_ch13.adb (working copy) @@ -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 -- --------------------------- Index: sem_ch13.ads =================================================================== --- sem_ch13.ads (revision 241105) +++ sem_ch13.ads (working copy) @@ -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);