From patchwork Mon May 2 09:58:06 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 617449 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 3qz0B15FVrz9t3q for ; Mon, 2 May 2016 19:58:33 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=Vcx/Cz5W; 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=EAcxGIN6t3YwJarWtr0DfJxEjlkrno75Z381NbkrNfvI6PUnqO +yR8bEyK+SyWvFsLFkiGN0dvQboMPRnAPPQSiSemN8p3qpgXnxIw4Lz7lmYeqNUf dIX4QtU4MCuagQSraRzix5ijq5cH3uZtZH46flfd/jGA2LY/sH3B/Zvqo= 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=1uebgHdToePFoVAVk2aUnfq+JDQ=; b=Vcx/Cz5WnC9w2NrqUcot UfsfT+3r4lEMHTTcXP4GPKCuFl3/D0V3a5z4UEvJWd0O2MTSDIBDHfm5VFMf3TAt xyXVA6LqO3yCKe/fkiw5wV/9BggASE4Uo6+mjyiLoFlTbQ76THRqrKo8c42uhanJ 0mYL4FyynTu2rf+eUk+SqiQ= Received: (qmail 98758 invoked by alias); 2 May 2016 09:58:13 -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 98728 invoked by uid 89); 2 May 2016 09:58:13 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=2.2 required=5.0 tests=AWL, BAYES_50, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY, RCVD_IN_DNSWL_NONE autolearn=no version=3.3.2 spammy=frozen, elsif, etype, Etype 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 (AES256-SHA encrypted) ESMTPS; Mon, 02 May 2016 09:58:08 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 87BFB116735; Mon, 2 May 2016 05:58:06 -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 sB7JqjaQrU9q; Mon, 2 May 2016 05:58:06 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 76E92116729; Mon, 2 May 2016 05:58:06 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 75FD441B; Mon, 2 May 2016 05:58:06 -0400 (EDT) Date: Mon, 2 May 2016 05:58:06 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Predicate checks when Assertion policy is Ignore Message-ID: <20160502095806.GA136810@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch implements the proper semantics of predicated subtypes in various contexts when the assertion policy is Ignore. This affects the semantics of case constructs and object declarations when values that do not satisfy the predicate are present. Tested in ACATS 4.0J tests C54003 and C457005 Tested on x86_64-pc-linux-gnu, committed on trunk 2016-05-02 Ed Schonberg * einfo.ads, einfo.adb (Predicates_Ignared): new flag to indicate that predicate checking is disabled for predicated subtypes in the context of an Assertion_Policy pragma. * checks.adb (Apply_Predicate_Check): Do nothing if Predicates_Ignored is true. * exp_ch3.adb (Expand_Freeze_Enumeration_Type): If Predicates_Ignores is true, the function Rep_To_Pos does raise an exception for invalid data. * exp_ch4.adb (Expand_N_Type_Conversion): IF target is a predicated type do not apply check if Predicates_Ignored is true. * exp_ch5.adb (Expand_N_Case_Statement): If Predicates_Ignored is true, sem_prag.adb: * sem_ch3.adb (Analyze_Object_Declaration): If Predicates_Ignored is true do not emit predicate check on initializing expression. Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 235711) +++ exp_ch5.adb (working copy) @@ -2573,10 +2573,11 @@ -- does not obey the predicate, the value is marked non-static, and -- there can be no corresponding static alternative. In that case we -- replace the case statement with an exception, regardless of whether - -- assertions are enabled or not. + -- assertions are enabled or not, unless predicates are ignored. if Compile_Time_Known_Value (Expr) and then Has_Predicates (Etype (Expr)) + and then not Predicates_Ignored (Etype (Expr)) and then not Is_OK_Static_Expression (Expr) then Rewrite (N, @@ -2659,7 +2660,9 @@ -- comes from source -- no need to validity check internally -- generated case statements). - if Validity_Check_Default then + if Validity_Check_Default + and then not Predicates_Ignored (Etype (Expr)) + then Ensure_Valid (Expr); end if; @@ -2788,9 +2791,31 @@ if not Others_Present then Others_Node := Make_Others_Choice (Sloc (Last_Alt)); - Set_Others_Discrete_Choices - (Others_Node, Discrete_Choices (Last_Alt)); - Set_Discrete_Choices (Last_Alt, New_List (Others_Node)); + + -- If Predicates_Ignored is true the value does not satisfy the + -- predicate, and there is no Others choice, Constraint_Error + -- must be raised (4.5.7 (21/3)). + + if Predicates_Ignored (Etype (Expr)) then + declare + Except : constant Node_Id := + Make_Raise_Constraint_Error (Loc, + Reason => CE_Invalid_Data); + New_Alt : constant Node_Id := + Make_Case_Statement_Alternative (Loc, + Discrete_Choices => New_List (Make_Others_Choice (Loc)), + Statements => New_List (Except)); + begin + Append (New_Alt, Alternatives (N)); + Analyze_And_Resolve (Except); + end; + + else + Set_Others_Discrete_Choices + (Others_Node, Discrete_Choices (Last_Alt)); + Set_Discrete_Choices (Last_Alt, New_List (Others_Node)); + end if; + end if; -- Deal with possible declarations of controlled objects, and also Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 235706) +++ sem_ch3.adb (working copy) @@ -3814,14 +3814,15 @@ -- do this in the analyzer and not the expander because the analyzer -- does some substantial rewriting in some cases. - -- We need a predicate check if the type has predicates, and if either - -- there is an initializing expression, or for default initialization - -- when we have at least one case of an explicit default initial value - -- and then this is not an internal declaration whose initialization - -- comes later (as for an aggregate expansion). + -- We need a predicate check if the type has predicates that are not + -- ignored, and if either there is an initializing expression, or for + -- default initialization when we have at least one case of an explicit + -- default initial value and then this is not an internal declaration + -- whose initialization comes later (as for an aggregate expansion). if not Suppress_Assignment_Checks (N) and then Present (Predicate_Function (T)) + and then not Predicates_Ignored (T) and then not No_Initialization (N) and then (Present (E) Index: einfo.adb =================================================================== --- einfo.adb (revision 235706) +++ einfo.adb (working copy) @@ -601,8 +601,8 @@ -- Is_Volatile_Full_Access Flag285 -- Is_Exception_Handler Flag286 -- Rewritten_For_C Flag287 + -- Predicates_Ignored Flag288 - -- (unused) Flag288 -- (unused) Flag289 -- (unused) Flag300 @@ -2910,6 +2910,12 @@ return Node14 (Id); end Postconditions_Proc; + function Predicates_Ignored (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag288 (Id); + end Predicates_Ignored; + function Prival (Id : E) return E is begin pragma Assert (Is_Protected_Component (Id)); @@ -5971,6 +5977,12 @@ Set_Node14 (Id, V); end Set_Postconditions_Proc; + procedure Set_Predicates_Ignored (Id : E; V : B) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag288 (Id, V); + end Set_Predicates_Ignored; + procedure Set_Direct_Primitive_Operations (Id : E; V : L) is begin pragma Assert (Is_Tagged_Type (Id)); @@ -9130,6 +9142,7 @@ W ("Reverse_Bit_Order", Flag164 (Id)); W ("Reverse_Storage_Order", Flag93 (Id)); W ("Rewritten_For_C", Flag287 (Id)); + W ("Predicates_Ignored", Flag288 (Id)); W ("Sec_Stack_Needed_For_Return", Flag167 (Id)); W ("Size_Depends_On_Discriminant", Flag177 (Id)); W ("Size_Known_At_Compile_Time", Flag92 (Id)); Index: einfo.ads =================================================================== --- einfo.ads (revision 235713) +++ einfo.ads (working copy) @@ -3767,6 +3767,11 @@ -- is the special version created for membership tests, where if one of -- these raise expressions is executed, the result is to return False. +-- Predicates_Ignored (Flag288) +-- Defined on all types. Indicates whether the subtype declaration is in +-- a context where Assertion_Policy is Ignore, in which case no checks +-- (static or dynamic) must be generated for objects of the type. + -- Primitive_Operations (synthesized) -- Defined in concurrent types, tagged record types and subtypes, tagged -- private types and tagged incomplete types. For concurrent types whose @@ -7137,6 +7142,7 @@ function Partial_View_Has_Unknown_Discr (Id : E) return B; function Pending_Access_Types (Id : E) return L; function Postconditions_Proc (Id : E) return E; + function Predicates_Ignored (Id : E) return B; function Prival (Id : E) return E; function Prival_Link (Id : E) return E; function Private_Dependents (Id : E) return L; @@ -7489,6 +7495,7 @@ procedure Set_Depends_On_Private (Id : E; V : B := True); procedure Set_Derived_Type_Link (Id : E; V : E); procedure Set_Digits_Value (Id : E; V : U); + procedure Set_Predicates_Ignored (Id : E; V : B); procedure Set_Direct_Primitive_Operations (Id : E; V : L); procedure Set_Directly_Designated_Type (Id : E; V : E); procedure Set_Disable_Controlled (Id : E; V : B := True); @@ -8637,6 +8644,7 @@ pragma Inline (Partial_View_Has_Unknown_Discr); pragma Inline (Pending_Access_Types); pragma Inline (Postconditions_Proc); + pragma Inline (Predicates_Ignored); pragma Inline (Prival); pragma Inline (Prival_Link); pragma Inline (Private_Dependents); @@ -9100,6 +9108,7 @@ pragma Inline (Set_Partial_View_Has_Unknown_Discr); pragma Inline (Set_Pending_Access_Types); pragma Inline (Set_Postconditions_Proc); + pragma Inline (Set_Predicates_Ignored); pragma Inline (Set_Prival); pragma Inline (Set_Prival_Link); pragma Inline (Set_Private_Dependents); Index: checks.adb =================================================================== --- checks.adb (revision 235714) +++ checks.adb (working copy) @@ -2670,6 +2670,9 @@ if Predicate_Checks_Suppressed (Empty) then return; + elsif Predicates_Ignored (Typ) then + return; + elsif Present (Predicate_Function (Typ)) then S := Current_Scope; while Present (S) and then not Is_Subprogram (S) loop Index: sem_prag.adb =================================================================== --- sem_prag.adb (revision 235713) +++ sem_prag.adb (working copy) @@ -18744,8 +18744,15 @@ -- the rep item chain, for processing when the type is frozen. -- This is accomplished by a call to Rep_Item_Too_Late. We also -- mark the type as having predicates. + -- If the current policy is Ignore mark the subtype accordingly. + -- In the case of predicates we consider them enabled unless an + -- Ignore is specified, to preserve existing warnings. Set_Has_Predicates (Typ); + Set_Predicates_Ignored (Typ, + Present (Check_Policy_List) + and then + Policy_In_Effect (Name_Assertion_Policy) = Name_Ignore); Discard := Rep_Item_Too_Late (Typ, N, FOnly => True); end Predicate; @@ -28563,6 +28570,7 @@ -- RM defined Name_Assert | + Name_Assertion_Policy | Name_Static_Predicate | Name_Dynamic_Predicate | Name_Pre | Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 235710) +++ exp_ch4.adb (working copy) @@ -11387,6 +11387,7 @@ -- internal conversions for the purpose of checking predicates. if Present (Predicate_Function (Target_Type)) + and then not Predicates_Ignored (Target_Type) and then Target_Type /= Operand_Type and then Comes_From_Source (N) then Index: exp_ch3.adb =================================================================== --- exp_ch3.adb (revision 235729) +++ exp_ch3.adb (working copy) @@ -5034,9 +5034,13 @@ end loop; end if; - -- In normal mode, add the others clause with the test + -- In normal mode, add the others clause with the test. + -- If Predicates_Ignored is True, validity checks do not apply to + -- the subtype. - if not No_Exception_Handlers_Set then + if not No_Exception_Handlers_Set + and then not Predicates_Ignored (Typ) + then Append_To (Lst, Make_Case_Statement_Alternative (Loc, Discrete_Choices => New_List (Make_Others_Choice (Loc)),