From patchwork Fri Oct 31 11:03:08 2014 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 405272 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 0B5D614007F for ; Fri, 31 Oct 2014 22:03:25 +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=j1Q3b0R43Ktycz6/6jXyIplXUet5OaeL7XdX2WChDM1/y5UPMJ B7Sx/ZPYBbDp4x1queYviP7wLMt7iZaMdFYx1MuvntxIXxQi69NhOSnnMCkYk5QU +lmahmNO0q2N/3quJN+K2WpyLz4E+UszaYGhbHscpZqHSAoSrg8nMzSbs= 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=dnPzfHSXMoUoP1zetoBzk9xtZig=; b=mYOelKBxrNgaV6Rd6DYt y0Fqu7hSMk7jdSRpAhl5Rup5bdEk2ZiY9rm3jQpoUXja95T6YKALWgU5Xel7eMM+ JyNiAUfCz7k2/8WFezbClAdy/38ylPx1Y5kLxZJQwV1SVVpVrnBbP1KoxbM+Bxp/ LDMCe/cZd5AxeRX64exs1vQ= Received: (qmail 32227 invoked by alias); 31 Oct 2014 11:03:12 -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 32150 invoked by uid 89); 31 Oct 2014 11:03:12 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-0.0 required=5.0 tests=BAYES_40 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:03:10 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 43E181161B1; Fri, 31 Oct 2014 07:03:08 -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 ePsfyPRUFgTu; Fri, 31 Oct 2014 07:03:08 -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 3378311619A; Fri, 31 Oct 2014 07:03:08 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id 323E93FE21; Fri, 31 Oct 2014 07:03:08 -0400 (EDT) Date: Fri, 31 Oct 2014 07:03:08 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Handling of implicit dereference in instantiations Message-ID: <20141031110308.GA26965@adacore.com> MIME-Version: 1.0 Content-Disposition: inline User-Agent: Mutt/1.5.21 (2010-09-15) The use of reference types and generalized indexing leads to multiple tree rewritings. When these uses are in a generic unit, the transformations are not propagated to instantiations, and the analysis of the instance must replicate that of the generic to recognize the presence of implicit dereferences. This patch removes some global information from selected components whose prefix involves an implicit dereference, to force the re-analysis and resolution in the instantiation. Executing; gnatmake -q cont cont must yield: 1234 1234 1234 2468 --- with Par; use Par; with Par.Child; with Ada.Finalization; use Ada.Finalization; procedure Cont is use My_Lists; Bunch : List; Ptr : Cursor; package Inst is new Par.Child; use Inst; begin Append (Bunch, R'(Controlled with Kind => 1234)); Try (Bunch, Bunch.First); end; --- with ada.containers.doubly_linked_lists; with Ada.Finalization; use Ada.Finalization; use ada.containers; package Par is type R is new Ada.Finalization.Controlled with record Kind : Integer; end record; package My_Lists is new Doubly_Linked_Lists (R); end Par; --- generic package Par.Child is use My_Lists; procedure Try (Bunch: List; C : Cursor); end Par.Child; -- with Text_IO; use Text_IO; package body Par.Child is use My_Lists; procedure Try (Bunch: List; C : Cursor) is V1 : Integer := Constant_Reference (Bunch, C).Element.Kind; V2 : Integer := Constant_Reference (Bunch, C).Kind; V3 : Integer := Bunch (C).Kind; begin Put_Line (Integer'Image (V1)); Put_Line (Integer'Image (V2)); Put_Line (Integer'Image (V3)); for Elmt of Bunch loop Put_Line (Integer'Image (2 * Elmt.Kind)); end loop; end; end Par.Child; Tested on x86_64-pc-linux-gnu, committed on trunk 2014-10-31 Ed Schonberg * sem_ch4.adb (Try_Container_Indexing): Use Check_Implicit_Dereference. * sem_util.adb (Check_Implicit_Dereference): a) Handle generalized indexing as well as function calls. b) If the context is a selected component and whe are in an instance, remove entity from selector name to force resolution of the node, so that explicit dereferences can be generated in the instance if they were in the generic unit. Index: sem_util.adb =================================================================== --- sem_util.adb (revision 216925) +++ sem_util.adb (working copy) @@ -2673,17 +2673,29 @@ -- Check_Implicit_Dereference -- -------------------------------- - procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id) is + procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id) is Disc : Entity_Id; Desig : Entity_Id; + Nam : Node_Id; begin + if Nkind (N) = N_Indexed_Component + and then Present (Generalized_Indexing (N)) + then + Nam := Generalized_Indexing (N); + + else + Nam := N; + end if; + if Ada_Version < Ada_2012 or else not Has_Implicit_Dereference (Base_Type (Typ)) then return; - elsif not Comes_From_Source (Nam) then + elsif not Comes_From_Source (N) + and then Nkind (N) /= N_Indexed_Component + then return; elsif Is_Entity_Name (Nam) and then Is_Type (Entity (Nam)) then @@ -2695,6 +2707,26 @@ if Has_Implicit_Dereference (Disc) then Desig := Designated_Type (Etype (Disc)); Add_One_Interp (Nam, Disc, Desig); + + -- If the node is a generalized indexing, add interpretation + -- to that node as well, for subsequent resolution. + + if Nkind (N) = N_Indexed_Component then + Add_One_Interp (N, Disc, Desig); + end if; + + -- If the operation comes from a generic unit and the context + -- is a selected component, the selector name may be global + -- and set in the instance already. Remove the entity to + -- force resolution of the selected component, and the + -- generation of an explicit dereference if needed. + + if In_Instance + and then Nkind (Parent (Nam)) = N_Selected_Component + then + Set_Entity (Selector_Name (Parent (Nam)), Empty); + end if; + exit; end if; @@ -16543,11 +16575,21 @@ begin -- Nothing to do if argument is Empty or has Debug_Info_Off set, which -- indicates that Debug_Info_Needed is never required for the entity. + -- Nothing to do if entity comes from a predefined file. Library files + -- are compiled without debug information, but inlined bodies of these + -- routines may appear in user code, and debug information on them ends + -- up complicating debugging the user code. if No (T) or else Debug_Info_Off (T) then return; + + elsif In_Inlined_Body + and then Is_Predefined_File_Name + (Unit_File_Name (Get_Source_Unit (Sloc (T)))) + then + Set_Needs_Debug_Info (T, False); end if; -- Set flag in entity itself. Note that we will go through the following Index: sem_util.ads =================================================================== --- sem_util.ads (revision 216925) +++ sem_util.ads (working copy) @@ -285,10 +285,12 @@ -- the one containing C2, that is known to refer to the same object (RM -- 6.4.1(6.17/3)). - procedure Check_Implicit_Dereference (Nam : Node_Id; Typ : Entity_Id); + procedure Check_Implicit_Dereference (N : Node_Id; Typ : Entity_Id); -- AI05-139-2: Accessors and iterators for containers. This procedure -- checks whether T is a reference type, and if so it adds an interprettion - -- to Expr whose type is the designated type of the reference_discriminant. + -- to N whose type is the designated type of the reference_discriminant. + -- If N is a generalized indexing operation, the interpretation is added + -- both to the corresponding function call, and to the indexing node. procedure Check_Internal_Protected_Use (N : Node_Id; Nam : Entity_Id); -- Within a protected function, the current object is a constant, and Index: sem_ch4.adb =================================================================== --- sem_ch4.adb (revision 216925) +++ sem_ch4.adb (working copy) @@ -7036,7 +7036,6 @@ Loc : constant Source_Ptr := Sloc (N); C_Type : Entity_Id; Assoc : List_Id; - Disc : Entity_Id; Func : Entity_Id; Func_Name : Node_Id; Indexing : Node_Id; @@ -7149,21 +7148,7 @@ -- discriminant is not the first discriminant. if Has_Discriminants (Etype (Func)) then - Disc := First_Discriminant (Etype (Func)); - while Present (Disc) loop - declare - Elmt_Type : Entity_Id; - begin - if Has_Implicit_Dereference (Disc) then - Elmt_Type := Designated_Type (Etype (Disc)); - Add_One_Interp (Indexing, Disc, Elmt_Type); - Add_One_Interp (N, Disc, Elmt_Type); - exit; - end if; - end; - - Next_Discriminant (Disc); - end loop; + Check_Implicit_Dereference (N, Etype (Func)); end if; else @@ -7194,18 +7179,7 @@ -- Add implicit dereference interpretation if Has_Discriminants (Etype (It.Nam)) then - Disc := First_Discriminant (Etype (It.Nam)); - while Present (Disc) loop - if Has_Implicit_Dereference (Disc) then - Add_One_Interp - (Indexing, Disc, Designated_Type (Etype (Disc))); - Add_One_Interp - (N, Disc, Designated_Type (Etype (Disc))); - exit; - end if; - - Next_Discriminant (Disc); - end loop; + Check_Implicit_Dereference (N, Etype (It.Nam)); end if; exit;