From patchwork Wed Sep 6 13:21: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: 810586 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-461611-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="t8BExwwU"; 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 3xnPQK6tQVz9t3Z for ; Wed, 6 Sep 2017 23:22:33 +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=Uu4CgeAEtOp5gcvx7ovOkagytNcvwtdefbW6vvkaysWI2qqxTc y+Ji7F4wp403NYHigbXpTGOcMwDzOMIXFoQNtVcrCUES4J6d1k/ziWYgjCyR6jOc udnzSpilkyiukCmtA8A+78eJrjf1n9fsbWdYt6Nr4f2KGyhxZpJs+aaoY= 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=IykH0IjHRW43u4OchQYT8h2hmUc=; b=t8BExwwUrgCwn6MI64Wc +xLRp/nBhJuPx544m0c4TFvlzvYyA0iTX2Xgw/dt1XnPPKQPOWpH1Q+0NLcms9z1 nWz1I1ML0N67ZeMDdBU3LkbbHV0t+xzDBFQXw5OFpWQbY6179qRNzA8O57iiteNa hu7yB83j+hHFXtg6ogGNUTU= Received: (qmail 54555 invoked by alias); 6 Sep 2017 13:22:00 -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 54409 invoked by uid 89); 6 Sep 2017 13:22:00 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-11.9 required=5.0 tests=BAYES_00, GIT_PATCH_2, GIT_PATCH_3, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=ham version=3.3.2 spammy=yoyo, Hx-languages-length:2932, Prior 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 13:21:54 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 8FBE056426; Wed, 6 Sep 2017 09:21:52 -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 O3aireKXQgJg; Wed, 6 Sep 2017 09:21:52 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [IPv6:2620:20:4000:0:46a8:42ff:fe0e:e294]) by rock.gnat.com (Postfix) with ESMTP id 7F50556425; Wed, 6 Sep 2017 09:21:52 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 7E59F4AC; Wed, 6 Sep 2017 09:21:52 -0400 (EDT) Date: Wed, 6 Sep 2017 09:21:52 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Wrong code on assignment of conditional expression to a mutable obkect Message-ID: <20170906132152.GA81503@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) This patch fixes an error in an assignmen statement to an entity of a mutable type (variable or in-out parameter) when the righ-hand side of the assignment is a conditioal expression, some of whose alternatives are aggregates. Prior to this patch, not all components of the mutable object were properly assigned the corresponding values of the aggregate. Executing: gnatmake -q bug ./bug must yield: local var 72 local var 42 in_out parameter 72 in_out parameter 42 --- with Ada.Text_IO; procedure Bug is type Yoyo (Exists : Boolean := False) is record case Exists is when False => null; when True => Value : Integer := 5; end case; end record; Var1 : Yoyo; Var2 : Yoyo; procedure Test (Condition : in Boolean; Value : in Integer; Yo : in out Yoyo) is Var3 : Yoyo; begin Yo := (if Condition then (Exists => True, Value => Value) else (Exists => False)); Var3 := (case condition is when True => (Exists => True, Value => Value), when False => (Exists => False)); if Condition and then Yo.Value /= Value then Ada.Text_IO.Put_Line ("Compiler bug exposed"); end if; if Condition then Ada.Text_IO.Put_Line ("local var " & Integer'Image (Var3.Value)); end if; end; begin Test (True, 72, Var1); Test (True, 42, Var2); Ada.Text_IO.Put_Line ("in_out parameter " & Var1.Value'Img); Ada.Text_IO.Put_Line ("in_out parameter " & Var2.Value'Img); Test (False, 1000, Var1); end Bug; Tested on x86_64-pc-linux-gnu, committed on trunk 2017-09-06 Ed Schonberg * sem_ch5.adb (Analyze_Assigment): If the left-hand side is an entity of a mutable type and the right-hand side is a conditional expression, resolve the alternatives of the conditional using the base type of the target entity, because the alternatives may have distinct subtypes. This is particularly relevant if the alternatives are aggregates. Index: sem_ch5.adb =================================================================== --- sem_ch5.adb (revision 251789) +++ sem_ch5.adb (working copy) @@ -580,8 +580,27 @@ Set_Assignment_Type (Lhs, T1); - Resolve (Rhs, T1); + -- If the target of the assignment is an entity of a mutable type + -- and the expression is a conditional expression, its alternatives + -- can be of different subtypes of the nominal type of the LHS, so + -- they must be resolved with the base type, given that their subtype + -- may differ frok that of the target mutable object. + if Is_Entity_Name (Lhs) + and then Ekind_In (Entity (Lhs), + E_Variable, + E_Out_Parameter, + E_In_Out_Parameter) + and then Is_Composite_Type (T1) + and then not Is_Constrained (Etype (Entity (Lhs))) + and then Nkind_In (Rhs, N_If_Expression, N_Case_Expression) + then + Resolve (Rhs, Base_Type (T1)); + + else + Resolve (Rhs, T1); + end if; + -- This is the point at which we check for an unset reference Check_Unset_Reference (Rhs);