From patchwork Wed Nov 23 11:25:52 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 127268 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]) by ozlabs.org (Postfix) with SMTP id C5FC51007D2 for ; Wed, 23 Nov 2011 22:26:13 +1100 (EST) Received: (qmail 18791 invoked by alias); 23 Nov 2011 11:26:11 -0000 Received: (qmail 18777 invoked by uid 22791); 23 Nov 2011 11:26:10 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL,BAYES_00 X-Spam-Check-By: sourceware.org Received: from rock.gnat.com (HELO rock.gnat.com) (205.232.38.15) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Wed, 23 Nov 2011 11:25:53 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id B919F2BB1E4; Wed, 23 Nov 2011 06:25:52 -0500 (EST) 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 yvhK0HGWq0Bk; Wed, 23 Nov 2011 06:25:52 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 97B262BB16D; Wed, 23 Nov 2011 06:25:52 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id 960393FEE8; Wed, 23 Nov 2011 06:25:52 -0500 (EST) Date: Wed, 23 Nov 2011 06:25:52 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Robert Dewar Subject: [Ada] Fix check for entry family bounds out of range Message-ID: <20111123112552.GA21389@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.20 (2009-06-14) 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 This patch adds code to the semantic analyzer to properly check that entry family bounds are in range. Previously this check was done during code expansion, leading to messages posted at the wrong point, omission of the check in -gnatc mode, and in the case of task entry families a blow up in the expander. The following tests compile with the errors shown in both normal and -gnatc modes. 1. procedure badentrymsg is 2. protected type PT is 3. entry Test (Long_Long_Integer) | >>> entry family low bound must be >= 0 >>> entry family high bound must be <= 16#7FFF_FFFF# 4. (X : Integer); 5. private 6. Data : Integer := 0; 7. end PT; 8. 9. protected body PT is 10. entry Test 11. (for I in Long_Long_Integer) 12. (X : Integer) 13. when True is 14. begin 15. Data := X; 16. end Test; 17. end PT; 18. PO : PT; 19. begin 20. PO.Test(3)(5); 21. end; 1. procedure badtaskentry is 2. Data : Integer; 3. task type PT is 4. entry Test (Long_Long_Integer) | >>> entry family low bound must be >= 0 >>> entry family high bound must be <= 16#7FFF_FFFF# 5. (X : Integer); 6. end PT; 7. 8. task body PT is 9. begin 10. accept Test (3) (X : Integer) do 11. Data := X; 12. end Test; 13. end PT; 14. 15. T : PT; 16. begin 17. null; 18. end; Tested on x86_64-pc-linux-gnu, committed on trunk 2011-11-23 Robert Dewar * sem_ch9.adb (Analyze_Entry_Declaration): Check for entry family bounds out of range. Index: sem_ch9.adb =================================================================== --- sem_ch9.adb (revision 181654) +++ sem_ch9.adb (working copy) @@ -905,6 +905,60 @@ Bad_Predicated_Subtype_Use ("subtype& has predicate, not allowed in entry family", D_Sdef, Etype (D_Sdef)); + + -- Check entry family static bounds outside allowed limits + + -- Note: originally this check was not performed here, but in that + -- case the check happens deep in the expander, and the message is + -- posted at the wrong location, and omitted in -gnatc mode. + + declare + PEI : constant Entity_Id := RTE (RE_Protected_Entry_Index); + LB : constant Uint := Expr_Value (Type_Low_Bound (PEI)); + UB : constant Uint := Expr_Value (Type_High_Bound (PEI)); + + LBR : Node_Id; + UBR : Node_Id; + + begin + if Nkind (D_Sdef) = N_Range then + LBR := Low_Bound (D_Sdef); + elsif Is_Entity_Name (D_Sdef) + and then Is_Type (Entity (D_Sdef)) + then + LBR := Type_Low_Bound (Entity (D_Sdef)); + else + goto Skip_LB; + end if; + + if Is_Static_Expression (LBR) + and then Expr_Value (LBR) < LB + then + Error_Msg_Uint_1 := LB; + Error_Msg_N ("entry family low bound must be '>'= ^!", D_Sdef); + end if; + + <> + if Nkind (D_Sdef) = N_Range then + UBR := High_Bound (D_Sdef); + elsif Is_Entity_Name (D_Sdef) + and then Is_Type (Entity (D_Sdef)) + then + UBR := Type_High_Bound (Entity (D_Sdef)); + else + goto Skip_UB; + end if; + + if Is_Static_Expression (UBR) + and then Expr_Value (UBR) > UB + then + Error_Msg_Uint_1 := UB; + Error_Msg_N ("entry family high bound must be '<'= ^!", D_Sdef); + end if; + + <> + null; + end; end if; -- Decorate Def_Id