From patchwork Mon Jun 14 08:16:50 2010 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 55485 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 7DB41B7D83 for ; Mon, 14 Jun 2010 18:16:48 +1000 (EST) Received: (qmail 16960 invoked by alias); 14 Jun 2010 08:16:46 -0000 Received: (qmail 16950 invoked by uid 22791); 14 Jun 2010 08:16:45 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, T_RP_MATCHES_RCVD X-Spam-Check-By: sourceware.org Received: from mel.act-europe.fr (HELO mel.act-europe.fr) (212.99.106.210) by sourceware.org (qpsmtpd/0.43rc1) with ESMTP; Mon, 14 Jun 2010 08:16:41 +0000 Received: from localhost (localhost [127.0.0.1]) by filtered-smtp.eu.adacore.com (Postfix) with ESMTP id 31F70CB021C; Mon, 14 Jun 2010 10:16:44 +0200 (CEST) Received: from mel.act-europe.fr ([127.0.0.1]) by localhost (smtp.eu.adacore.com [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id UuwY5+5QlC7e; Mon, 14 Jun 2010 10:16:44 +0200 (CEST) Received: from saumur.act-europe.fr (saumur.act-europe.fr [10.10.0.183]) by mel.act-europe.fr (Postfix) with ESMTP id E9163CB021B; Mon, 14 Jun 2010 10:16:43 +0200 (CEST) Received: by saumur.act-europe.fr (Postfix, from userid 525) id BD85BD8808; Mon, 14 Jun 2010 10:16:50 +0200 (CEST) Date: Mon, 14 Jun 2010 10:16:50 +0200 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Heap objects constrained by their initial value Message-ID: <20100614081650.GA12383@adacore.com> Mime-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.9i X-IsSubscribed: yes 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 If a heap object has an indefinite subtype, it is constrained by its initial value, and when it is the target of an assignment a discriminant check must be performed on the right-hand side. This patch extends this check to the case where the object is a renaming of a heap object. Previously the check only applied to explicit dereferences of heap objects. The following, compiled in 2005 mode, must yield at execution: raised CONSTRAINT_ERROR : check.adb:15 discriminant check failed --- proredure Check is type T (D: Boolean := True) is record I: Integer; end record; type T_Access is access T; P_V: constant T_Access := new T; V: T renames P_V.all; P_W: constant T_Access := new T'(False, 0); W: T renames P_W.all; begin V := W; -- must raise constraint error. end Check; Tested on x86_64-pc-linux-gnu, committed on trunk 2010-06-14 Ed Schonberg * checks.adb (Apply_Discriminant_Check): If the target of the assignment is a renaming of a heap object, create constrained type for it to apply check. Index: checks.adb =================================================================== --- checks.adb (revision 160705) +++ checks.adb (working copy) @@ -1084,6 +1084,11 @@ package body Checks is Cond : Node_Id; T_Typ : Entity_Id; + function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean; + -- A heap object with an indefinite subtype is constrained by its + -- initial value, and assigning to it requires a constraint_check. + -- The target may be an explicit dereference, or a renaming of one. + function Is_Aliased_Unconstrained_Component return Boolean; -- It is possible for an aliased component to have a nominal -- unconstrained subtype (through instantiation). If this is a @@ -1091,6 +1096,21 @@ package body Checks is -- in an initialization, the check must be suppressed. This unusual -- situation requires a predicate of its own. + ---------------------------------- + -- Denotes_Explicit_Dereference -- + ---------------------------------- + + function Denotes_Explicit_Dereference (Obj : Node_Id) return Boolean is + begin + return + Nkind (Obj) = N_Explicit_Dereference + or else + (Is_Entity_Name (Obj) + and then Present (Renamed_Object (Entity (Obj))) + and then Nkind (Renamed_Object (Entity (Obj))) + = N_Explicit_Dereference); + end Denotes_Explicit_Dereference; + ---------------------------------------- -- Is_Aliased_Unconstrained_Component -- ---------------------------------------- @@ -1164,7 +1184,7 @@ package body Checks is -- Ada 2005 (AI-363): For Ada 2005, we limit the building of the actual -- subtype to the parameter and dereference cases, since other aliased -- objects are unconstrained (unless the nominal subtype is explicitly - -- constrained). (But we also need to test for renamings???) + -- constrained). if Present (Lhs) and then (Present (Param_Entity (Lhs)) @@ -1174,7 +1194,7 @@ package body Checks is and then not Is_Aliased_Unconstrained_Component) or else (Ada_Version >= Ada_05 and then not Is_Constrained (T_Typ) - and then Nkind (Lhs) = N_Explicit_Dereference + and then Denotes_Explicit_Dereference (Lhs) and then Nkind (Original_Node (Lhs)) /= N_Function_Call)) then