From patchwork Fri Sep 2 09:54:25 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 113081 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 4BC23B6F71 for ; Fri, 2 Sep 2011 19:54:56 +1000 (EST) Received: (qmail 10716 invoked by alias); 2 Sep 2011 09:54:49 -0000 Received: (qmail 10695 invoked by uid 22791); 2 Sep 2011 09:54:46 -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; Fri, 02 Sep 2011 09:54:26 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id C97232BB0FF; Fri, 2 Sep 2011 05:54:25 -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 MT3GBHQR0bkW; Fri, 2 Sep 2011 05:54:25 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 8C2E72BABB6; Fri, 2 Sep 2011 05:54:25 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 8AF973FEE8; Fri, 2 Sep 2011 05:54:25 -0400 (EDT) Date: Fri, 2 Sep 2011 05:54:25 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Actuals that are function calls returning unconstrained limited types Message-ID: <20110902095425.GA31448@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 fixes an omission in the code that resolves actuals in a call. Previous to this patch, and actual in a call that is an overloaded function call, one of whose interpretations returns an unconstrained limited type may be resolved incorrectly. The command gnatmake -q -gnat05 main main Must yield Create for Type_A --- with Lib; use Lib; procedure Main is A : Type_A (2); begin Set (A, Create (2)); end Main; --- private with Ada.Finalization; package Lib is type Type_B (Value : Integer) is tagged limited private; function Create (Value : Integer) return Type_B; type Type_A (Value : Integer) is tagged limited private; function Create (Value : Integer) return Type_A; procedure Set (Left : in out Type_A; Right : Type_A); private use Ada.Finalization; type Type_B (Value : Integer) is new Limited_Controlled with null record; type Natural_A is access Natural; type Type_A (Value : Integer) is new Limited_Controlled with record Refcount : Natural_A; end record; overriding procedure Initialize (Object : in out Type_A); procedure Adjust (Object : in out Type_A); overriding procedure Finalize (Object : in out Type_A); end Lib; --- with Ada.Text_IO; with System.Storage_Elements; with Unchecked_Deallocation; package body Lib is use Ada.Text_IO; procedure Free is new Unchecked_Deallocation (Natural, Natural_A); overriding procedure Initialize (Object : in out Type_A) is begin Object.Refcount := new Natural'(1); end Initialize; procedure Adjust (Object : in out Type_A) is begin raise Program_Error with "Never override Adjust for Limited type."; end Adjust; overriding procedure Finalize (Object : in out Type_A) is Refcount : Natural_A := Object.Refcount; begin Object.Refcount := null; -- Finalize must be idempotent if Refcount = null then null; else Refcount.all := Refcount.all - 1; if Refcount.all = 0 then Free (Refcount); end if; end if; end Finalize; procedure Set (Left : in out Type_A; Right : Type_A) is begin if Left.Value /= Right.Value then Put_Line ("Left.Value, Right.Value : " & Left.Value'Img & ", " & Right.Value'Img); raise Constraint_Error with "Set : Discriminant Values don't match"; end if; Left.Finalize; Left.Refcount := Right.Refcount; Left.Refcount.all := Left.Refcount.all + 1; end Set; function Create (Value : Integer) return Type_A is begin return R : Type_A (Value) do Put_Line ("Create for Type_A"); end return; end Create; function Create (Value : Integer) return Type_B is begin return R : Type_B (Value) do Put_Line ("Create for Type_B"); end return; end Create; end Lib; Tested on x86_64-pc-linux-gnu, committed on trunk 2011-09-02 Ed Schonberg * sem_res.adb (Resolve_Actuals): add missing call to Resolve for an actual that is a function call returning an unconstrained limited controlled type. Index: sem_res.adb =================================================================== --- sem_res.adb (revision 178381) +++ sem_res.adb (working copy) @@ -3446,6 +3446,7 @@ and then (Is_Controlled (Etype (F)) or else Has_Task (Etype (F))) then Establish_Transient_Scope (A, False); + Resolve (A, Etype (F)); -- A small optimization: if one of the actuals is a concatenation -- create a block around a procedure call to recover stack space.