From patchwork Fri Sep 8 09:44:59 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 811425 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Authentication-Results: ozlabs.org; spf=pass (mailfrom) smtp.mailfrom=gcc.gnu.org (client-ip=209.132.180.131; helo=sourceware.org; envelope-from=gcc-patches-return-461712-incoming=patchwork.ozlabs.org@gcc.gnu.org; receiver=) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b="I2Hhb1V+"; dkim-atps=neutral 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 3xpXWB1wd1z9s7p for ; Fri, 8 Sep 2017 19:45:42 +1000 (AEST) 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=D0El1blC0cKeqBNbE/vAb0JthEbl1BgcFivM3QXtVY9CjmY9Hx afsYf0MdckM8zVjaiKTg67eGA2nwR1rWEx6RdEezaW4AjYDdHh2tMOtgAgvYJPcT 52zrhHwDatiPnsD6OpvEn3yCDgsZGDjQLatQqROM0rOLIWEAtlUfxb92U= 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=UblNYpQe0p8azy3Tzye95eai4RA=; b=I2Hhb1V+OKijp9Bhn8t2 xp4HWFZngDWn0gEpTwvBwo5iu0w0+R5gutOkPi5N+gcmsvVnWxMjU11AGIMzbVeE hY7TUShNik8wgPbG7hmNs/00ZS1bd8FXnXK44YsNSNojfwP9Ki1662AykPF+v5LG LX8l+oRh7LZJNtcSzLclpQ4= Received: (qmail 14464 invoked by alias); 8 Sep 2017 09:45:27 -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 8309 invoked by uid 89); 8 Sep 2017 09:45:16 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-15.0 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_1, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy= 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; Fri, 08 Sep 2017 09:45:01 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id A5AD35619D; Fri, 8 Sep 2017 05:44:59 -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 2xJGPptZZ34m; Fri, 8 Sep 2017 05:44:59 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 94CC856126; Fri, 8 Sep 2017 05:44:59 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 93DA9505; Fri, 8 Sep 2017 05:44:59 -0400 (EDT) Date: Fri, 8 Sep 2017 05:44:59 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Subtype indications inherit predicates Message-ID: <20170908094459.GA59649@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) A subtype indication whose type mark is a predicated subtype inherits the predicates of its parent type. A loop whose specification has the form: for S1 in T range Lo .. Hi loop ... and in which T has a static predicate, is executed over the values of T in the specified range that satisfy the predicate. Previous to this patch the inherited predicate was ignored and the loop executed for all values in the range. Executing: gnatmake -q main main must yield: TRUE TRUE Forward 3 4 10 11 12 Backwards 12 11 10 4 3 --- with Bar; use Bar; procedure Main is begin P; end; --- package Bar with SPARK_Mode is subtype B is Boolean with Static_Predicate => B = True; subtype C is integer with Static_Predicate => C in 1..4 | 10..20; function Ident (X : B) return B is (X); function Bizarre (X : Boolean) return B is (Ident (X)); procedure P; end Bar; --- With TExt_IO; use Text_IO; package body Bar with SPARK_Mode is procedure P is Thing : B; Thing2 : B := True; begin for X in B range False .. True loop THing := X; Thing := THing2; Put_Line (Thing'Img); end loop; put_line ("Forward"); for Y in C range 3 .. 12 loop Put_Line (Integer'Image (Y)); end loop; put_line ("Backwards"); for Y in reverse C range 3 .. 12 loop Put_Line (Integer'Image (Y)); end loop; end P; end Bar; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-08 Ed Schonberg * exp_ch5.adb (Expand_Predicated_Loop): Handle properly a loop over a subtype of a type with a static predicate, taking into account the predicate function of the parent type and the bounds given in the loop specification. * sem_ch3.adb (Inherit_Predicate_Flags): For qn Itype created for a loop specification that is a subtype indication whose type mark is a type with a static predicate, inherit predicate function, used to build case statement for rewritten loop. Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 251863) +++ exp_ch5.adb (working copy) @@ -4698,6 +4698,10 @@ -- end loop; -- end; + -- In addition, if the loop specification is given by a subtype + -- indication that constrains a predicated type, the bounds of + -- iteration are given by those of the subtype indication. + else Static_Predicate : declare S : Node_Id; @@ -4706,6 +4710,11 @@ Alts : List_Id; Cstm : Node_Id; + -- If the domain is an itype, note the bounds of its range. + + L_Hi : Node_Id; + L_Lo : Node_Id; + function Lo_Val (N : Node_Id) return Node_Id; -- Given static expression or static range, returns an identifier -- whose value is the low bound of the expression value or range. @@ -4760,6 +4769,11 @@ Set_Warnings_Off (Loop_Id); + if Is_Itype (Ltype) then + L_Hi := High_Bound (Scalar_Range (Ltype)); + L_Lo := Low_Bound (Scalar_Range (Ltype)); + end if; + -- Loop to create branches of case statement Alts := New_List; @@ -4768,12 +4782,21 @@ -- Initial value is largest value in predicate. - D := - Make_Object_Declaration (Loc, - Defining_Identifier => Loop_Id, - Object_Definition => New_Occurrence_Of (Ltype, Loc), - Expression => Hi_Val (Last (Stat))); + if Is_Itype (Ltype) then + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => L_Hi); + else + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => Hi_Val (Last (Stat))); + end if; + P := Last (Stat); while Present (P) loop if No (Prev (P)) then @@ -4794,15 +4817,34 @@ Prev (P); end loop; + if Is_Itype (Ltype) + and then Is_OK_Static_Expression (L_Lo) + and then + Expr_Value (L_Lo) /= Expr_Value (Lo_Val (First (Stat))) + then + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Statements => New_List (Make_Exit_Statement (Loc)), + Discrete_Choices => New_List (L_Lo))); + end if; + else -- Initial value is smallest value in predicate. - D := - Make_Object_Declaration (Loc, - Defining_Identifier => Loop_Id, - Object_Definition => New_Occurrence_Of (Ltype, Loc), - Expression => Lo_Val (First (Stat))); + if Is_Itype (Ltype) then + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => L_Lo); + else + D := + Make_Object_Declaration (Loc, + Defining_Identifier => Loop_Id, + Object_Definition => New_Occurrence_Of (Ltype, Loc), + Expression => Lo_Val (First (Stat))); + end if; P := First (Stat); while Present (P) loop @@ -4823,6 +4865,17 @@ Next (P); end loop; + + if Is_Itype (Ltype) + and then Is_OK_Static_Expression (L_Hi) + and then + Expr_Value (L_Hi) /= Expr_Value (Lo_Val (Last (Stat))) + then + Append_To (Alts, + Make_Case_Statement_Alternative (Loc, + Statements => New_List (Make_Exit_Statement (Loc)), + Discrete_Choices => New_List (L_Hi))); + end if; end if; -- Add others choice Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 251871) +++ sem_ch3.adb (working copy) @@ -18449,6 +18449,19 @@ (Subt, Has_Static_Predicate_Aspect (Par)); Set_Has_Dynamic_Predicate_Aspect (Subt, Has_Dynamic_Predicate_Aspect (Par)); + + -- A named subtype does not inherit the predicate function of its + -- parent but an itype declared for a loop index needs the discrete + -- predicate information of its parent to execute the loop properly. + + if Is_Itype (Subt) and then Present (Predicate_Function (Par)) then + Set_Subprograms_For_Type (Subt, Subprograms_For_Type (Par)); + + if Has_Static_Predicate (Par) then + Set_Static_Discrete_Predicate + (Subt, Static_Discrete_Predicate (Par)); + end if; + end if; end Inherit_Predicate_Flags; ----------------------