From patchwork Wed Sep 6 09:54:52 2017 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 810481 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-461570-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="NI5IisI5"; 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 3xnJq80Tknz9sCZ for ; Wed, 6 Sep 2017 19:55:15 +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=OmiSRYr5FCtFuaEoZg7aHcHDUDs80k0UjB4eXShmkunynSuoQE 5YHnEcrtkET/7ITeM/sEG2SNCRmfkn6P29+acfFYM7HKZxTnvmnffwc+MWTAiz2Z 5xpIYJU3jSmUQL9Yq0pxJjmg979TtubSNv+E709FmbhvmHNDVmBFbQ/cU= 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=alEQz0wVYENdlz3vGlaRzWYLjXg=; b=NI5IisI5wy1UL11AqUIS Mwq3WrAcEg/0EL/7mYNG3LELwICAndBsjpfMfxMzBW8NALd4WCEdCLyfr+LiG2iD R3mWoFYfS6A9AbDARo7QooWsTxbvYpXUkrmUdMgjCbdX/PzQzWUeXv8OqRJIGl6k yrHwXaK8HSWZ/eqv588ANPg= Received: (qmail 21023 invoked by alias); 6 Sep 2017 09:54:57 -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 20948 invoked by uid 89); 6 Sep 2017 09:54:57 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-10.4 required=5.0 tests=AWL, BAYES_00, GIT_PATCH_2, GIT_PATCH_3, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=BB, BD, BS, Cons 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; Wed, 06 Sep 2017 09:54:54 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 0532856141; Wed, 6 Sep 2017 05:54:53 -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 lHfpqdeF-tdu; Wed, 6 Sep 2017 05:54:52 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id E8A045606C; Wed, 6 Sep 2017 05:54:52 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id E79FC4FC; Wed, 6 Sep 2017 05:54:52 -0400 (EDT) Date: Wed, 6 Sep 2017 05:54:52 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Spurious errors on derived untagged types with partial constraints Message-ID: <20170906095452.GA79470@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch fixes the handling of untagged discriminated derived types that constrain some parent discriminants and rename others. The compiler failed to handle a change of representation on the derived type, and generated faulty code for the initialization procedure or such a derived type. Executing: --- gnatmake -q p p -- must yield: -- 1234 TRUE 20 discriminant rules!! --- with Q; use Q; with Text_IO; use Text_IO; procedure P is procedure Inner (B : Base) is begin null; -- Put_Line (B.S); Put_Line (Integer'Image (B.I)); Put_Line (Boolean'Image (B.B)); Put_Line (Integer'Image (B.D)); Put_Line (B.S); end; D1 : Derived (True); begin D1.S := "discriminant rules!!"; Inner (Base (D1)); end; --- package Q is type Base (D : Positive; B : Boolean) is record I : Integer := 1234; S : String (1 .. D); -- := (1 .. D => 'Q'); end record; type Derived (B : Boolean) is new Base (D => 20, B => B); for Derived use record I at 0 range 0 .. 31; end record; Thing : Derived (False); end Q; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * exp_ch4.adb (Handle_Changed_Representation): For an untagged derived type with a mixture of renamed and constrained parent discriminants, the constraint for the target must obtain the discriminant values from both the operand and from the stored constraint for it, given that the constrained discriminants are not visible in the object. * exp_ch5.adb (Make_Field_Assign): The type of the right-hand side may be derived from that of the left-hand side (as in the case of an assignment with a change of representation) so the discriminant to be used in the retrieval of the value of the component must be the entity in the type of the right-hand side. Index: exp_ch5.adb =================================================================== --- exp_ch5.adb (revision 251753) +++ exp_ch5.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1448,9 +1448,21 @@ U_U : Boolean := False) return Node_Id is A : Node_Id; + Disc : Entity_Id; Expr : Node_Id; begin + + -- The discriminant entity to be used in the retrieval below must + -- be one in the corresponding type, given that the assignment + -- may be between derived and parent types. + + if Is_Derived_Type (Etype (Rhs)) then + Disc := Find_Component (R_Typ, C); + else + Disc := C; + end if; + -- In the case of an Unchecked_Union, use the discriminant -- constraint value as on the right-hand side of the assignment. @@ -1463,7 +1475,7 @@ Expr := Make_Selected_Component (Loc, Prefix => Duplicate_Subexpr (Rhs), - Selector_Name => New_Occurrence_Of (C, Loc)); + Selector_Name => New_Occurrence_Of (Disc, Loc)); end if; A := Index: exp_ch4.adb =================================================================== --- exp_ch4.adb (revision 251758) +++ exp_ch4.adb (working copy) @@ -10627,7 +10627,6 @@ Temp : Entity_Id; Decl : Node_Id; Odef : Node_Id; - Disc : Node_Id; N_Ix : Node_Id; Cons : List_Id; @@ -10657,23 +10656,70 @@ if not Is_Constrained (Target_Type) then if Has_Discriminants (Operand_Type) then - Disc := First_Discriminant (Operand_Type); - if Disc /= First_Stored_Discriminant (Operand_Type) then - Disc := First_Stored_Discriminant (Operand_Type); - end if; + -- A change of representation can only apply to untagged + -- types. We need to build the constraint that applies to + -- the target type, using the constraints of the operand. + -- The analysis is complicated if there are both inherited + -- discriminants and constrained discriminants. + -- We iterate over the discriminants of the target, and + -- find the discriminant of the same name: - Cons := New_List; - while Present (Disc) loop - Append_To (Cons, - Make_Selected_Component (Loc, - Prefix => - Duplicate_Subexpr_Move_Checks (Operand), - Selector_Name => - Make_Identifier (Loc, Chars (Disc)))); - Next_Discriminant (Disc); - end loop; + -- a) If there is a corresponding discriminant in the object + -- then the value is a selected component of the operand. + -- b) Otherwise the value of a constrained discriminant is + -- found in the stored constraint of the operand. + + declare + Stored : constant Elist_Id := + Stored_Constraint (Operand_Type); + + Elmt : Elmt_Id; + + Disc_O : Entity_Id; + -- Discriminant of the operand type. Its value in the + -- the object is captured in a selected component. + + Disc_S : Entity_Id; + -- Stored discriminant of the operand. If present, it + -- corresponds to a constrained discriminant of the + -- parent type. + + Disc_T : Entity_Id; + -- Discriminant of the target type + + begin + Disc_T := First_Discriminant (Target_Type); + Disc_O := First_Discriminant (Operand_Type); + Disc_S := First_Stored_Discriminant (Operand_Type); + + if Present (Stored) then + Elmt := First_Elmt (Stored); + end if; + + Cons := New_List; + while Present (Disc_T) loop + if Present (Disc_O) + and then Chars (Disc_T) = Chars (Disc_O) + then + Append_To (Cons, + Make_Selected_Component (Loc, + Prefix => + Duplicate_Subexpr_Move_Checks (Operand), + Selector_Name => + Make_Identifier (Loc, Chars (Disc_O)))); + Next_Discriminant (Disc_O); + + elsif Present (Disc_S) then + Append_To (Cons, New_Copy_Tree (Node (Elmt))); + Next_Elmt (Elmt); + end if; + + Next_Discriminant (Disc_T); + end loop; + end; + elsif Is_Array_Type (Operand_Type) then N_Ix := First_Index (Target_Type); Cons := New_List;