From patchwork Wed Apr 27 12:55:24 2016 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 615630 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]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id 3qw0M52QSKz9t3w for ; Wed, 27 Apr 2016 22:56:01 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=js0qUTRO; dkim-atps=neutral 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=bhxRJ6DmqQs0Sh81oq1LhHzC1HcGcuBgRAvYWVGlEvHCSeRt8a GP1TwFCaNtzQSq5nDnR1Fb4KyVTACiqkUxSBbv4cRwj6WYBwTfSQtKFF3iiTjJlW KqK+xBkKbaJpBfgo4QjiZKBbJbP4GMT8SgGi8Ly83C6JxIU2KYtDCx9LM= 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=D3I1r+8HnrD09+WbQ8KakqqrDVc=; b=js0qUTRONDDJixcXKsx+ 0mn1LQDh+RE4CMUoouayHJ8zGKJjueusLiHwwr5dOx5RPgqTxfZqmk81EH48lRQu 5qJxcUowO6FwKwxKLGSXGThKo9DvUDtgER4KHGsrGAkErFyyjyGQ5ki5qLF8Tk2u 5HVo0E+EcjBm6QvHnyCwiAA= Received: (qmail 85628 invoked by alias); 27 Apr 2016 12:55:37 -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 85589 invoked by uid 89); 27 Apr 2016 12:55:36 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=2.2 required=5.0 tests=AWL, BAYES_50, KAM_ASCII_DIVIDERS, KAM_LAZY_DOMAIN_SECURITY, RCVD_IN_DNSWL_NONE autolearn=no version=3.3.2 spammy=entity_id, Entity_Id, Node_Id, node_id 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 (AES256-SHA encrypted) ESMTPS; Wed, 27 Apr 2016 12:55:26 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 7CD98116AD7; Wed, 27 Apr 2016 08:55:24 -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 aZIVa4cMpLhp; Wed, 27 Apr 2016 08:55:24 -0400 (EDT) Received: from tron.gnat.com (tron.gnat.com [205.232.38.10]) by rock.gnat.com (Postfix) with ESMTP id 6CC6711686C; Wed, 27 Apr 2016 08:55:24 -0400 (EDT) Received: by tron.gnat.com (Postfix, from userid 4192) id 6949F370; Wed, 27 Apr 2016 08:55:24 -0400 (EDT) Date: Wed, 27 Apr 2016 08:55:24 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Javier Miranda Subject: [Ada] wrong interface type conversion of in-out parameter Message-ID: <20160427125524.GA20581@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.23 (2014-03-12) The compiler silently skips generating the code to perform a type conversion when the all the following conditions occur: 1) the target type of the type conversion is an access to a class-wide interface type; 2) the type conversion is performed when passing an in-out access type actual to a subprogram; and 3) in the declaration of the called subprogram the type of that access to interface formal is visible through a limited-with clause. After this patch the following test compiles and executes well. package Types is type Iface is interface; type Ref_Iface is access all Iface'Class; procedure Enter (Self : in Iface) is abstract; type Parent is abstract tagged null record; type Object is new Parent and Iface with null record; type Ref_Object is access all Object'Class; not overriding procedure Some_Primitive (Self : in Object); overriding procedure Enter (Self : in Object); end; with GNAT.IO; package body Types is procedure Some_Primitive(Self : Object) is pragma Unreferenced (Self); begin GNAT.IO.Put_Line ("ERROR: wrong dispatching call"); end; procedure Enter(Self : in Object) is pragma Unreferenced (Self); begin GNAT.IO.Put("OK"); end; end; limited with Types; -- [3] package Do_Test is procedure Test (The_Bar : in out Types.Ref_Iface); -- [2] end; with Types; with GNAT.IO; use GNAT.IO; package body Do_Test is procedure Test (The_Bar : in out Types.Ref_Iface) is begin The_Bar.Enter; end; end; with Types; with Do_Test; procedure Main is The_Pub : Types.Ref_Object := new Types.Object; begin Do_Test.Test (Types.Ref_Iface(The_Pub)); -- [1] end; Command: gnatmake main.adb; ./main Output: OK Tested on x86_64-pc-linux-gnu, committed on trunk 2016-04-27 Javier Miranda * exp_ch6.adb (Add_Call_By_Copy_Code, Add_Simple_Call_By_Copy_Code, Expand_Actuals): Handle formals whose type comes from the limited view. Index: exp_ch6.adb =================================================================== --- exp_ch6.adb (revision 235493) +++ exp_ch6.adb (working copy) @@ -1198,14 +1198,14 @@ --------------------------- procedure Add_Call_By_Copy_Code is + Crep : Boolean; Expr : Node_Id; + F_Typ : Entity_Id := Etype (Formal); + Indic : Node_Id; Init : Node_Id; Temp : Entity_Id; - Indic : Node_Id; + V_Typ : Entity_Id; Var : Entity_Id; - F_Typ : constant Entity_Id := Etype (Formal); - V_Typ : Entity_Id; - Crep : Boolean; begin if not Is_Legal_Copy then @@ -1214,6 +1214,14 @@ Temp := Make_Temporary (Loc, 'T', Actual); + -- Handle formals whose type comes from the limited view + + if From_Limited_With (F_Typ) + and then Has_Non_Limited_View (F_Typ) + then + F_Typ := Non_Limited_View (F_Typ); + end if; + -- Use formal type for temp, unless formal type is an unconstrained -- array, in which case we don't have to worry about bounds checks, -- and we use the actual type, since that has appropriate bounds. @@ -1221,7 +1229,7 @@ if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then Indic := New_Occurrence_Of (Etype (Actual), Loc); else - Indic := New_Occurrence_Of (Etype (Formal), Loc); + Indic := New_Occurrence_Of (F_Typ, Loc); end if; if Nkind (Actual) = N_Type_Conversion then @@ -1473,20 +1481,28 @@ ---------------------------------- procedure Add_Simple_Call_By_Copy_Code is - Temp : Entity_Id; Decl : Node_Id; + F_Typ : Entity_Id := Etype (Formal); Incod : Node_Id; + Indic : Node_Id; + Lhs : Node_Id; Outcod : Node_Id; - Lhs : Node_Id; Rhs : Node_Id; - Indic : Node_Id; - F_Typ : constant Entity_Id := Etype (Formal); + Temp : Entity_Id; begin if not Is_Legal_Copy then return; end if; + -- Handle formals whose type comes from the limited view + + if From_Limited_With (F_Typ) + and then Has_Non_Limited_View (F_Typ) + then + F_Typ := Non_Limited_View (F_Typ); + end if; + -- Use formal type for temp, unless formal type is an unconstrained -- array, in which case we don't have to worry about bounds checks, -- and we use the actual type, since that has appropriate bounds. @@ -1494,7 +1510,7 @@ if Is_Array_Type (F_Typ) and then not Is_Constrained (F_Typ) then Indic := New_Occurrence_Of (Etype (Actual), Loc); else - Indic := New_Occurrence_Of (Etype (Formal), Loc); + Indic := New_Occurrence_Of (F_Typ, Loc); end if; -- Prepare to generate code @@ -1517,7 +1533,7 @@ if Ekind (Formal) = E_Out_Parameter then Incod := Empty; - if Has_Discriminants (Etype (Formal)) then + if Has_Discriminants (F_Typ) then Indic := New_Occurrence_Of (Etype (Actual), Loc); end if; @@ -1719,6 +1735,14 @@ E_Formal := Etype (Formal); E_Actual := Etype (Actual); + -- Handle formals whose type comes from the limited view + + if From_Limited_With (E_Formal) + and then Has_Non_Limited_View (E_Formal) + then + E_Formal := Non_Limited_View (E_Formal); + end if; + if Is_Scalar_Type (E_Formal) or else Nkind (Actual) = N_Slice then