From patchwork Tue Aug 2 12:24:15 2011 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Arnaud Charlet X-Patchwork-Id: 107902 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 62C04B71CE for ; Tue, 2 Aug 2011 22:24:49 +1000 (EST) Received: (qmail 20281 invoked by alias); 2 Aug 2011 12:24:46 -0000 Received: (qmail 20272 invoked by uid 22791); 2 Aug 2011 12:24:44 -0000 X-SWARE-Spam-Status: No, hits=-1.7 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; Tue, 02 Aug 2011 12:24:16 +0000 Received: from localhost (localhost.localdomain [127.0.0.1]) by filtered-rock.gnat.com (Postfix) with ESMTP id 07D0B2BB152; Tue, 2 Aug 2011 08:24:16 -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 ncBZIZbxgzUm; Tue, 2 Aug 2011 08:24:15 -0400 (EDT) Received: from kwai.gnat.com (kwai.gnat.com [205.232.38.4]) by rock.gnat.com (Postfix) with ESMTP id DDFD82BAF94; Tue, 2 Aug 2011 08:24:15 -0400 (EDT) Received: by kwai.gnat.com (Postfix, from userid 4192) id CCC503FEE8; Tue, 2 Aug 2011 08:24:15 -0400 (EDT) Date: Tue, 2 Aug 2011 08:24:15 -0400 From: Arnaud Charlet To: gcc-patches@gcc.gnu.org Cc: Ed Schonberg Subject: [Ada] Iteration of containers given by function calls Message-ID: <20110802122415.GA22617@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 In Ada2012, the domain of iteration of a loop or quantified expression can be a function call that yields a container. This patch implements the support for default iterators over such expressions, that is to say iterators that use the default indexing machinery present in all containers. The following must compile quietly: gcc -c -gnata -gnat12 t.adb --- with Ada.Containers.Doubly_Linked_Lists; package T is package Lists is new Ada.Containers.Doubly_Linked_Lists (Integer); use Lists; function Id (L : List) return List; procedure Map_F (L : in out List) with Post => (for all Cu in Id (L) => Element (Cu) = 0); end T; --- with Text_IO; use Text_IO; package body T is function Id (L : List) return List is begin return L; end; procedure Map_F (L : in out List) -- with Result : Lists.List; is begin for I of L Loop put_line (integer'image (I)); end loop; Result.Append (0); L := Result; end; end T; Tested on x86_64-pc-linux-gnu, committed on trunk 2011-08-02 Ed Schonberg * sem_ch5.adb (Pre_Analyze_Range): new procedure extracted from Process_Bounds, to perform analysis with expansion of a range or an expression that is the iteration scheme for a loop. (Analyze_Iterator_Specification): If domain of iteration is given by a function call with a controlled result, as is the case if call returns a predefined container, ensure that finalization actions are properly generated. * par-ch3.adb: accept Ada2012 iterator form in P_Discrete_Range. Index: par-ch3.adb =================================================================== --- par-ch3.adb (revision 177123) +++ par-ch3.adb (working copy) @@ -2783,11 +2783,17 @@ Set_High_Bound (Range_Node, Expr_Node); return Range_Node; - -- Otherwise we must have a subtype mark + -- Otherwise we must have a subtype mark, or an Ada 2012 iterator elsif Expr_Form = EF_Simple_Name then return Expr_Node; + -- The domain of iteration must be a name. Semantics will determine that + -- the expression has the proper form. + + elsif Ada_Version >= Ada_2012 then + return Expr_Node; + -- If incorrect, complain that we expect .. else Index: sem_ch5.adb =================================================================== --- sem_ch5.adb (revision 177132) +++ sem_ch5.adb (working copy) @@ -1537,6 +1537,90 @@ -- calls that use the secondary stack, returning True if any such call -- is found, and False otherwise. + procedure Pre_Analyze_Range (R_Copy : Node_Id); + -- Determine expected type of range or domain of iteration of Ada 2012 + -- loop by analyzing separate copy. Do the analysis and resolution of + -- the copy of the bound(s) with expansion disabled, to prevent the + -- generation of finalization actions. This prevents memory leaks when + -- the bounds contain calls to functions returning controlled arrays or + -- when the domain of iteration is a container. + + ----------------------- + -- Pre_Analyze_Range -- + ----------------------- + + procedure Pre_Analyze_Range (R_Copy : Node_Id) is + Save_Analysis : Boolean; + begin + Save_Analysis := Full_Analysis; + Full_Analysis := False; + Expander_Mode_Save_And_Set (False); + + Analyze (R_Copy); + + if Nkind (R_Copy) in N_Subexpr + and then Is_Overloaded (R_Copy) + then + + -- Apply preference rules for range of predefined integer types, + -- or diagnose true ambiguity. + + declare + I : Interp_Index; + It : Interp; + Found : Entity_Id := Empty; + + begin + Get_First_Interp (R_Copy, I, It); + while Present (It.Typ) loop + if Is_Discrete_Type (It.Typ) then + if No (Found) then + Found := It.Typ; + else + if Scope (Found) = Standard_Standard then + null; + + elsif Scope (It.Typ) = Standard_Standard then + Found := It.Typ; + + else + -- Both of them are user-defined + + Error_Msg_N + ("ambiguous bounds in range of iteration", + R_Copy); + Error_Msg_N ("\possible interpretations:", R_Copy); + Error_Msg_NE ("\\} ", R_Copy, Found); + Error_Msg_NE ("\\} ", R_Copy, It.Typ); + exit; + end if; + end if; + end if; + + Get_Next_Interp (I, It); + end loop; + end; + end if; + + if Is_Entity_Name (R_Copy) + and then Is_Type (Entity (R_Copy)) + then + + -- Subtype mark in iteration scheme + + null; + + elsif Nkind (R_Copy) in N_Subexpr then + + -- Expression in range, or Ada 2012 iterator + + Resolve (R_Copy); + end if; + + Expander_Mode_Restore; + Full_Analysis := Save_Analysis; + end Pre_Analyze_Range; + -------------------- -- Process_Bounds -- -------------------- @@ -1549,7 +1633,6 @@ New_Lo_Bound : Node_Id; New_Hi_Bound : Node_Id; Typ : Entity_Id; - Save_Analysis : Boolean; function One_Bound (Original_Bound : Node_Id; @@ -1653,65 +1736,8 @@ -- Start of processing for Process_Bounds begin - -- Determine expected type of range by analyzing separate copy Do the - -- analysis and resolution of the copy of the bounds with expansion - -- disabled, to prevent the generation of finalization actions on - -- each bound. This prevents memory leaks when the bounds contain - -- calls to functions returning controlled arrays. - Set_Parent (R_Copy, Parent (R)); - Save_Analysis := Full_Analysis; - Full_Analysis := False; - Expander_Mode_Save_And_Set (False); - - Analyze (R_Copy); - - if Is_Overloaded (R_Copy) then - - -- Apply preference rules for range of predefined integer types, - -- or diagnose true ambiguity. - - declare - I : Interp_Index; - It : Interp; - Found : Entity_Id := Empty; - - begin - Get_First_Interp (R_Copy, I, It); - while Present (It.Typ) loop - if Is_Discrete_Type (It.Typ) then - if No (Found) then - Found := It.Typ; - else - if Scope (Found) = Standard_Standard then - null; - - elsif Scope (It.Typ) = Standard_Standard then - Found := It.Typ; - - else - -- Both of them are user-defined - - Error_Msg_N - ("ambiguous bounds in range of iteration", - R_Copy); - Error_Msg_N ("\possible interpretations:", R_Copy); - Error_Msg_NE ("\\} ", R_Copy, Found); - Error_Msg_NE ("\\} ", R_Copy, It.Typ); - exit; - end if; - end if; - end if; - - Get_Next_Interp (I, It); - end loop; - end; - end if; - - Resolve (R_Copy); - Expander_Mode_Restore; - Full_Analysis := Save_Analysis; - + Pre_Analyze_Range (R_Copy); Typ := Etype (R_Copy); -- If the type of the discrete range is Universal_Integer, then the @@ -1904,6 +1930,8 @@ Id : constant Entity_Id := Defining_Identifier (LP); DS : constant Node_Id := Discrete_Subtype_Definition (LP); + D_Copy : Node_Id; + begin Enter_Name (Id); @@ -1946,15 +1974,19 @@ then Process_Bounds (DS); - -- Not a range or expander not active (is that right???) + -- Expander not active or else domain of iteration is a subtype + -- indication, an entity, or a function call that yields an + -- aggregate or a container. else - Analyze (DS); + D_Copy := New_Copy_Tree (DS); + Set_Parent (D_Copy, Parent (DS)); + Pre_Analyze_Range (D_Copy); - if Nkind (DS) = N_Function_Call + if Nkind (D_Copy) = N_Function_Call or else - (Is_Entity_Name (DS) - and then not Is_Type (Entity (DS))) + (Is_Entity_Name (D_Copy) + and then not Is_Type (Entity (D_Copy))) then -- This is an iterator specification. Rewrite as such -- and analyze. @@ -1964,8 +1996,7 @@ Make_Iterator_Specification (Sloc (LP), Defining_Identifier => Relocate_Node (Id), - Name => - Relocate_Node (DS), + Name => D_Copy, Subtype_Indication => Empty, Reverse_Present => @@ -1976,6 +2007,13 @@ Analyze_Iterator_Specification (I_Spec); return; end; + + else + + -- Domain of iteration is not a function call, and is + -- side-effect free. + + Analyze (DS); end if; end if; @@ -2145,9 +2183,10 @@ ------------------------------------- procedure Analyze_Iterator_Specification (N : Node_Id) is - Def_Id : constant Node_Id := Defining_Identifier (N); - Subt : constant Node_Id := Subtype_Indication (N); - Container : constant Node_Id := Name (N); + Loc : constant Source_Ptr := Sloc (N); + Def_Id : constant Node_Id := Defining_Identifier (N); + Subt : constant Node_Id := Subtype_Indication (N); + Container : constant Node_Id := Name (N); Ent : Entity_Id; Typ : Entity_Id; @@ -2160,7 +2199,43 @@ Analyze (Subt); end if; - Analyze_And_Resolve (Container); + -- If it is an expression, the container is pre-analyzed in the caller. + -- If it it of a controlled type we need a block for the finalization + -- actions. As for loop bounds that need finalization, we create a + -- declaration and an assignment to trigger these actions. + + if Present (Etype (Container)) + and then Is_Controlled (Etype (Container)) + and then not Is_Entity_Name (Container) + then + declare + Id : constant Entity_Id := Make_Temporary (Loc, 'R', Container); + Decl : Node_Id; + Assign : Node_Id; + + begin + Typ := Etype (Container); + + Decl := + Make_Object_Declaration (Loc, + Defining_Identifier => Id, + Object_Definition => New_Occurrence_Of (Typ, Loc)); + + Assign := + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Id, Loc), + Expression => Relocate_Node (Container)); + + Insert_Actions (Parent (N), New_List (Decl, Assign)); + end; + + else + + -- Container is an entity or an array with uncontrolled components + + Analyze_And_Resolve (Container); + end if; + Typ := Etype (Container); if Is_Array_Type (Typ) then