From patchwork Wed Feb 6 10:31:58 2013 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 218535 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 76ABE2C02C3 for ; Wed, 6 Feb 2013 21:32:16 +1100 (EST) Comment: DKIM? See http://www.dkim.org DKIM-Signature: v=1; a=rsa-sha1; c=relaxed/relaxed; d=gcc.gnu.org; s=default; x=1360751536; h=Comment: DomainKey-Signature:Received:Received:Received:Received:Received: Received:Received:Date:From:To:Cc:Subject:Message-ID: MIME-Version:Content-Type:Content-Disposition:User-Agent: Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive: List-Post:List-Help:Sender:Delivered-To; bh=S2E6tpYR918PwcAgM/nV v9oGFX8=; b=YpymA3JcBn17mjer8Znc8MlyEfAEXdfINx9TtAGAoFjwy+iaVXUl HzR7BMlzAFo7QaqUGGtZZcnAVyIV9m5tm5bSOQbUyLvlscTB3AKpolFfaLIAeSsc oq1Cq5mvXyEeEohJTiKru5csx1XMmJ7g1pIAgfVFn+csbFPNXAI+QR4= Comment: DomainKeys? See http://antispam.yahoo.com/domainkeys DomainKey-Signature: a=rsa-sha1; q=dns; c=nofws; s=default; d=gcc.gnu.org; h=Received:Received:X-SWARE-Spam-Status:X-Spam-Check-By:Received:Received:Received:Received:Received:Date:From:To:Cc:Subject:Message-ID:MIME-Version:Content-Type:Content-Disposition:User-Agent:Mailing-List:Precedence:List-Id:List-Unsubscribe:List-Archive:List-Post:List-Help:Sender:Delivered-To; b=iUZpw6K1izAORCiy5uAb5ayT6ospIKY/SnFUfVE4DKymNL52DwoRy/rZDt8zQS f5Mb94OijMjPnvbTTucNnL9g6DCNkA4795Q/cS2T2xxvOI96cCV1pf2CL8ep+xwh ByiF/tbYw1Qq5OYGaSGXEsBG+UQfhuaAboMk1W7c1PZbc=; Received: (qmail 6853 invoked by alias); 6 Feb 2013 10:32:07 -0000 Received: (qmail 6841 invoked by uid 22791); 6 Feb 2013 10:32:06 -0000 X-SWARE-Spam-Status: No, hits=-1.8 required=5.0 tests=AWL, BAYES_00, RCVD_IN_HOSTKARMA_NO, T_FILL_THIS_FORM_SHORT 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, 06 Feb 2013 10:31:59 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 8BC8F2E618; Wed, 6 Feb 2013 05:31:58 -0500 (EST) 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 1M1Z73M3f3qF; Wed, 6 Feb 2013 05:31:58 -0500 (EST) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id 5D8EF2E616; Wed, 6 Feb 2013 05:31:58 -0500 (EST) Received: by kwai.gnat.com (Postfix, from userid 4192) id 593CD3FF09; Wed, 6 Feb 2013 05:31:58 -0500 (EST) Date: Wed, 6 Feb 2013 05:31:58 -0500 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Hristian Kirtchev Subject: [Ada] Storage_Error due to large object size Message-ID: <20130206103158.GA28217@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 corrects the decoration of type attribute Has_Unknown_Discriminants when building the full view of a private subtype. ------------ -- Source -- ------------ -- root.ads package Root is end Root; -- root-scopes.ads package Root.Scopes is type Scope_T is interface; function Scope_Of (Scope_Name : String) return Scope_T is abstract; end Root.Scopes; -- root-scopes-basics.ads private package Root.Scopes.Basics is type Scope_T (Length : Natural) is abstract new Root.Scopes.Scope_T with record Name : String (1 .. Length) := (others => ' '); end record; end Root.Scopes.Basics; -- root-scopes-domains.ads private with Root.Scopes.Basics; generic package Root.Scopes.Domains is type Scope_T (<>) is new Root.Scopes.Scope_T with private; overriding function Scope_Of (Scope_Name : String) return Scope_T; private subtype Parent_T is Root.Scopes.Basics.Scope_T; type Scope_T is new Parent_T with record Comp : Integer; end record; end Root.Scopes.Domains; -- root-scopes-domains.adb package body Root.Scopes.Domains is function Scope_Of (Scope_Name : String) return Scope_T is begin return (Length => Scope_Name'Length, Name => Scope_Name, Comp => 5); end Scope_Of; end Root.Scopes.Domains; -- main.adb with Ada.Text_IO; use Ada.Text_IO; with Root.Scopes.Domains; procedure Main is package Inst is new Root.Scopes.Domains; subtype Scope_T is Inst.Scope_T; S_1 : constant Scope_T := Inst.Scope_Of ("One"); S_2 : Scope_T renames S_1; S_3 : Scope_T := Inst.Scope_Of ("Three"); begin Put_Line ("OK"); end Main; ---------------------------- -- Compilation and output -- ---------------------------- $ gnatmake -q -gnat05 main.adb $ ./main OK Tested on x86_64-pc-linux-gnu, committed on trunk 2013-02-06 Hristian Kirtchev * sem_ch3.adb (Complete_Private_Subtype): Inherit the Has_Unknown_Discriminants from the full view of the base type. Index: sem_ch3.adb =================================================================== --- sem_ch3.adb (revision 195788) +++ sem_ch3.adb (working copy) @@ -10255,15 +10255,17 @@ Protected_Kind => Copy_Node (Priv, Full); - Set_Has_Discriminants (Full, Has_Discriminants (Full_Base)); - Set_First_Entity (Full, First_Entity (Full_Base)); - Set_Last_Entity (Full, Last_Entity (Full_Base)); + Set_Has_Discriminants (Full, Has_Discriminants (Full_Base)); + Set_Has_Unknown_Discriminants + (Full, Has_Unknown_Discriminants (Full_Base)); + Set_First_Entity (Full, First_Entity (Full_Base)); + Set_Last_Entity (Full, Last_Entity (Full_Base)); when others => Copy_Node (Full_Base, Full); - Set_Chars (Full, Chars (Priv)); - Conditional_Delay (Full, Priv); - Set_Sloc (Full, Sloc (Priv)); + Set_Chars (Full, Chars (Priv)); + Conditional_Delay (Full, Priv); + Set_Sloc (Full, Sloc (Priv)); end case; Set_Next_Entity (Full, Save_Next_Entity); @@ -17388,7 +17390,6 @@ if Is_Private_Type (Id_B) then Append_Elmt (Id, Private_Dependents (Id_B)); end if; - end Prepare_Private_Subtype_Completion; ---------------------------