From patchwork Fri Oct 31 11:39:47 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 405287 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 B391614007D for ; Fri, 31 Oct 2014 22:39:57 +1100 (AEDT) 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=MO8NrvZ3sBul1wnQRSptbKoufqXPdTp1xwQmZAWAqJqEeiYC9B j22wuHwhQwGS+1fXDstZQnWxVrIydsWg+QWCBd/sM6fNF7EZ418gQ9Kp0i6oZxC5 3JpPdBm/bEYOiilKfbLGBY2svHE1MneJ9UuhlJI531TEFR7x+8z83UyZQ= 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=uwXyEvRJNjlHBh3Jj5CQeOqfQws=; b=AkzkVadEGUs12FeRC3hS z6M830BQ4k4mb7+ax2HroT/lgcoOY7rNEwpZEKqK6X16sXuM6hK8orZtx+VEoXar 9ovOZn0dnkKaWWw5sFJ4sM6xUkYqvTPOaBT9FiHT4TR6AekwimVYPhn1P9Dxk6R/ xvhrVaaf33ebl+DdYg64l/w= Received: (qmail 26476 invoked by alias); 31 Oct 2014 11:39:50 -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 26448 invoked by uid 89); 31 Oct 2014 11:39:49 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham version=3.3.2 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; Fri, 31 Oct 2014 11:39:48 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 1AD4A116426; Fri, 31 Oct 2014 07:39:47 -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 mYPpb7y0BBuf; Fri, 31 Oct 2014 07:39:47 -0400 (EDT) Received: from kwai.gnat.com (unknown [IPv6:2620:20:4000:0:7a2b:cbff:fe60:cb11]) by rock.gnat.com (Postfix) with ESMTP id 07F69116424; Fri, 31 Oct 2014 07:39:47 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 06B8F3FE21; Fri, 31 Oct 2014 07:39:47 -0400 (EDT) Date: Fri, 31 Oct 2014 07:39:47 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Handling of Default_Storage_Pool in generics and instantiations. Message-ID: <20141031113947.GA3361@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15) If there is a non-null default storage pool, a generic unit uses it for the allocators it may contain. At the point of instantiation, that default must be installed so that it applies to the allocators in the instance. This is achieved by adding an aspect specification Default_Storage_Pool to the generic, and propagating it to each instance. However, an instantiation may specify a different storage pool by means of the same aspect, which then overrides the one inherited from the generic unit. This patch implements both of these uses of default storage pools. No simple test available. Full test is proposed ACATS test cdb3dbm0. Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-31 Ed Schonberg * sem_ch12.adb (Analyze_Generic_Package_Declaration): If there is a default storage pool, add a corresponding aspect to the generic unit, to be used at the point of instantiation. (Analyze_Package_Instantiation): If generic unit has aspect specifications, propagate them to instance. If instance has a Default_Storage_Pool aspect, make sure that it overrides the one that may be inherited from the generic. Index: sem_ch12.adb =================================================================== --- sem_ch12.adb (revision 216963) +++ sem_ch12.adb (working copy) @@ -3437,6 +3437,27 @@ Check_References (Id); end if; end if; + + -- If there is a specified storage pool in the context, create an + -- aspect on the package declaration, so that it is used in any + -- instance that does not override it. + + if Present (Default_Pool) then + declare + ASN : Node_Id; + + begin + ASN := Make_Aspect_Specification (Loc, + Identifier => Make_Identifier (Loc, Name_Default_Storage_Pool), + Expression => New_Copy (Default_Pool)); + + if No (Aspect_Specifications (Specification (N))) then + Set_Aspect_Specifications (Specification (N), New_List (ASN)); + else + Append (ASN, Aspect_Specifications (Specification (N))); + end if; + end; + end if; end Analyze_Generic_Package_Declaration; -------------------------------------------- @@ -3605,6 +3626,7 @@ Act_Tree : Node_Id; Gen_Decl : Node_Id; + Gen_Spec : Node_Id; Gen_Unit : Entity_Id; Is_Actual_Pack : constant Boolean := @@ -3837,6 +3859,7 @@ end if; Gen_Decl := Unit_Declaration_Node (Gen_Unit); + Gen_Spec := Specification (Gen_Decl); -- Initialize renamings map, for error checking, and the list that -- holds private entities whose views have changed between generic @@ -3910,6 +3933,52 @@ New_Copy_List_Tree (Aspect_Specifications (Act_Tree))); end if; + -- The generic may have a generated Default_Storage_Pool aspect, + -- set at the point of generic declaration. If the instance has + -- that aspect, it overrides the one inherited from the generic. + + if Has_Aspects (Gen_Spec) then + if No (Aspect_Specifications (N)) then + Set_Aspect_Specifications (N, + (New_Copy_List_Tree + (Aspect_Specifications (Gen_Spec)))); + + else + declare + ASN1, ASN2 : Node_Id; + + begin + ASN1 := First (Aspect_Specifications (N)); + while Present (ASN1) loop + if Chars (Identifier (ASN1)) + = Name_Default_Storage_Pool + then + -- If generic carries a default storage pool, remove + -- it in favor of the instance one. + + ASN2 := First (Aspect_Specifications (Gen_Spec)); + while Present (ASN2) loop + if Chars (Identifier (ASN2)) + = Name_Default_Storage_Pool + then + Remove (ASN2); + exit; + end if; + + Next (ASN2); + end loop; + end if; + + Next (ASN1); + end loop; + + Prepend_List_To (Aspect_Specifications (N), + (New_Copy_List_Tree + (Aspect_Specifications (Gen_Spec)))); + end; + end if; + end if; + -- Save the instantiation node, for subsequent instantiation of the -- body, if there is one and we are generating code for the current -- unit. Mark unit as having a body (avoids premature error message). @@ -4212,6 +4281,40 @@ if Nkind (Parent (N)) /= N_Compilation_Unit then Mark_Rewrite_Insertion (Act_Decl); Insert_Before (N, Act_Decl); + + if Has_Aspects (N) then + Analyze_Aspect_Specifications (N, Act_Decl_Id); + + -- The pragma created for a Default_Storage_Pool aspect must + -- appear ahead of the declarations in the instance spec. + -- Analysis has placed it after the instance node, so remove + -- it and reinsert it properly now. + + declare + ASN : constant Node_Id := First (Aspect_Specifications (N)); + A_Name : constant Name_Id := Chars (Identifier (ASN)); + Decl : Node_Id; + + begin + if A_Name = Name_Default_Storage_Pool then + if No (Visible_Declarations (Act_Spec)) then + Set_Visible_Declarations (Act_Spec, New_List); + end if; + + Decl := Next (N); + while Present (Decl) loop + if Nkind (Decl) = N_Pragma then + Remove (Decl); + Prepend (Decl, Visible_Declarations (Act_Spec)); + exit; + end if; + + Next (Decl); + end loop; + end if; + end; + end if; + Analyze (Act_Decl); -- For an instantiation that is a compilation unit, place