From patchwork Wed Aug 3 10:50:30 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 108111 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 22301B71D0 for ; Wed, 3 Aug 2011 20:50:48 +1000 (EST) Received: (qmail 31511 invoked by alias); 3 Aug 2011 10:50:46 -0000 Received: (qmail 31500 invoked by uid 22791); 3 Aug 2011 10:50:45 -0000 X-SWARE-Spam-Status: No, hits=-1.7 required=5.0 tests=AWL,BAYES_00,TW_TM 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; Wed, 03 Aug 2011 10:50:31 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 79C592BB206; Wed, 3 Aug 2011 06:50:30 -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 UwnNvsdeBeJ8; Wed, 3 Aug 2011 06:50:30 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 62BCF2BB01F; Wed, 3 Aug 2011 06:50:30 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 61F6392A55; Wed, 3 Aug 2011 06:50:30 -0400 (EDT) Date: Wed, 3 Aug 2011 06:50:30 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Thomas Quinot Subject: [Ada] Default 'Input for array of limited object Message-ID: <20110803105030.GA15858@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 change fixes a bug in the generation of the default implementation of the 'Input stream attribute in Ada 2005 mode for the case of an unconstrained array of limited objects with a 'Read attribute. The following compilation must be accepted quietly: $ gcc -c -gnat05 unc_lim_input.adb with Ada.Streams; use Ada.Streams; package Limited_Remote is pragma Remote_Types; type T is tagged limited private; type A is array (Integer range <>) of T; procedure R (S : access Root_Stream_Type'Class; V : out A); for A'Read use R; procedure W (S : access Root_Stream_Type'Class; V : A); for A'Write use W; private type T is tagged limited null record; end Limited_Remote; with Ada.Streams; use Ada.Streams; with Limited_Remote; procedure Unc_Lim_Input (S : access Root_Stream_Type'Class) is procedure Do_Stuff (X : Limited_Remote.A) is begin null; end; begin Do_Stuff (Limited_Remote.A'Input (S)); end Unc_Lim_Input; Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-03 Thomas Quinot * exp_strm.adb (Build_Array_Input_Function): In Ada 2005 mode, when returning a limited array, use an extended return statement. Index: exp_strm.adb =================================================================== --- exp_strm.adb (revision 177026) +++ exp_strm.adb (working copy) @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2010, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2011, 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- -- @@ -149,7 +149,9 @@ Decls : List_Id; Ranges : List_Id; Stms : List_Id; + Rstmt : Node_Id; Indx : Node_Id; + Odecl : Node_Id; begin Decls := New_List; @@ -197,13 +199,13 @@ -- build a subtype indication with the proper bounds. if Is_Constrained (Stream_Base_Type (Typ)) then - Append_To (Decls, + Odecl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), Object_Definition => - New_Occurrence_Of (Stream_Base_Type (Typ), Loc))); + New_Occurrence_Of (Stream_Base_Type (Typ), Loc)); else - Append_To (Decls, + Odecl := Make_Object_Declaration (Loc, Defining_Identifier => Make_Defining_Identifier (Loc, Name_V), Object_Definition => @@ -212,20 +214,35 @@ New_Occurrence_Of (Stream_Base_Type (Typ), Loc), Constraint => Make_Index_Or_Discriminant_Constraint (Loc, - Constraints => Ranges)))); + Constraints => Ranges))); end if; - Stms := New_List ( - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Typ, Loc), - Attribute_Name => Name_Read, - Expressions => New_List ( - Make_Identifier (Loc, Name_S), - Make_Identifier (Loc, Name_V))), + Rstmt := Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Read, + Expressions => New_List ( + Make_Identifier (Loc, Name_S), + Make_Identifier (Loc, Name_V))); - Make_Simple_Return_Statement (Loc, - Expression => Make_Identifier (Loc, Name_V))); + if Ada_Version >= Ada_2005 then + Stms := New_List ( + Make_Extended_Return_Statement (Loc, + Return_Object_Declarations => New_List (Odecl), + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + New_List (Rstmt)))); + else + -- pragma Assert (not Is_Limited_Type (Typ)); + -- Returning a local object, shouldn't happen in the case of a + -- limited type, but currently occurs in DSA stubs in Ada 95 mode??? + Stms := New_List ( + Odecl, + Rstmt, + Make_Simple_Return_Statement (Loc, + Expression => Make_Identifier (Loc, Name_V))); + end if; + Fnam := Make_Defining_Identifier (Loc, Chars => Make_TSS_Name_Local (Typ, TSS_Stream_Input));