diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 2c18069d8f8f..9f4ee5e32e47 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2014-02-24 Ed Schonberg + + * sinfo.ads, sinfo.adb: New attribute Generalized_Indexing, for + indexed_components that are instances of Ada 2012 container + indexing operations. Analysis and resolution of such nodes + is performed on the attribute, and the original source is + preserved for ASIS operations. If expansion is enabled, the + indexed component is replaced by the value of this attribute, + which is in a call to an Indexing aspect, in most case wrapped + in a dereference operation. + * sem_ch4.adb (Analyze_Indexed_Component): Create + Generalized_Indexing attribute when appropriate. + (Analyze_Call): If prefix is not overloadable and has an indexing + aspect, transform into an indexed component so it can be analyzed + as a potential container indexing. + (Analyze_Expression): If node is an indexed component with a + Generalized_ Indexing, do not re-analyze. + * sem_res.adb (Resolve_Generalized_Indexing): Complete resolution + of an indexed_component that has been transformed into a container + indexing operation. + (Resolve_Indexed_Component): Call the above when required. + (Resolve): Do not insert an explicit dereference operation on + an indexed_component whose type has an implicit dereference: + the operation is inserted when resolving the related + Generalized_Indexing. + 2014-02-24 Olivier Ramonat * gnat_rm.texi, gnat_ugn.texi: Replace Ada Compiler by Ada Development diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 12fffbda6127..cab0aa3547b0 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1089,10 +1089,29 @@ package body Sem_Ch4 is else Nam_Ent := Entity (Nam); - -- If no interpretations, give error message + -- If not overloadable, this may be a generalized indexing + -- operation with named associations. Rewrite again as an + -- indexed component and analyze as container indexing. if not Is_Overloadable (Nam_Ent) then - No_Interpretation; + if Present ( + Find_Value_Of_Aspect + (Etype (Nam_Ent), Aspect_Constant_Indexing)) + then + Replace (N, + Make_Indexed_Component (Sloc (N), + Prefix => Nam, + Expressions => Parameter_Associations (N))); + + if Try_Container_Indexing (N, Nam, Expressions (N)) then + return; + else + No_Interpretation; + end if; + + else + No_Interpretation; + end if; return; end if; end if; @@ -1991,8 +2010,19 @@ package body Sem_Ch4 is procedure Analyze_Expression (N : Node_Id) is begin - Analyze (N); - Check_Parameterless_Call (N); + + -- If the expression is an indexed component that will be rewritten + -- as a container indexing, it has already been analyzed. + + if Nkind (N) = N_Indexed_Component + and then Present (Generalized_Indexing (N)) + then + null; + + else + Analyze (N); + Check_Parameterless_Call (N); + end if; end Analyze_Expression; ------------------------------------- @@ -6993,8 +7023,15 @@ package body Sem_Ch4 is Assoc := New_List (Relocate_Node (Prefix)); - -- A generalized iterator may have nore than one index expression, so + -- A generalized indexing may have nore than one index expression, so -- transfer all of them to the argument list to be used in the call. + -- Note that there may be named associations, in which case the node + -- was rewritten earlier as a call, and has been transformed back into + -- an indexed expression to share the following processing. + -- The generalized indexing node is the one on which analysis and + -- resolution take place. Before expansion the original node is replaced + -- with the generalized indexing node, which is a call, possibly with + -- a dereference operation. declare Arg : Node_Id; @@ -7012,21 +7049,31 @@ package body Sem_Ch4 is Make_Function_Call (Loc, Name => New_Occurrence_Of (Func, Loc), Parameter_Associations => Assoc); - Rewrite (N, Indexing); - Analyze (N); + Set_Parent (Indexing, Parent (N)); + Set_Generalized_Indexing (N, Indexing); + Analyze (Indexing); + Set_Etype (N, Etype (Indexing)); -- If the return type of the indexing function is a reference type, -- add the dereference as a possible interpretation. Note that the -- indexing aspect may be a function that returns the element type - -- with no intervening implicit dereference. + -- with no intervening implicit dereference, and that the reference + -- discriminant is not the first discriminant. if Has_Discriminants (Etype (Func)) then Disc := First_Discriminant (Etype (Func)); while Present (Disc) loop - if Has_Implicit_Dereference (Disc) then - Add_One_Interp (N, Disc, Designated_Type (Etype (Disc))); - exit; - end if; + 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; @@ -7038,7 +7085,8 @@ package body Sem_Ch4 is Name => Make_Identifier (Loc, Chars (Func_Name)), Parameter_Associations => Assoc); - Rewrite (N, Indexing); + Set_Parent (Indexing, Parent (N)); + Set_Generalized_Indexing (N, Indexing); declare I : Interp_Index; @@ -7047,12 +7095,13 @@ package body Sem_Ch4 is begin Get_First_Interp (Func_Name, I, It); - Set_Etype (N, Any_Type); + Set_Etype (Indexing, Any_Type); while Present (It.Nam) loop - Analyze_One_Call (N, It.Nam, False, Success); + Analyze_One_Call (Indexing, It.Nam, False, Success); if Success then - Set_Etype (Name (N), It.Typ); - Set_Entity (Name (N), It.Nam); + Set_Etype (Name (Indexing), It.Typ); + Set_Entity (Name (Indexing), It.Nam); + Set_Etype (N, Etype (Indexing)); -- Add implicit dereference interpretation @@ -7060,6 +7109,8 @@ package body Sem_Ch4 is 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; @@ -7076,12 +7127,10 @@ package body Sem_Ch4 is end; end if; - if Etype (N) = Any_Type then + if Etype (Indexing) = Any_Type then Error_Msg_NE ("container cannot be indexed with&", N, Etype (First (Exprs))); Rewrite (N, New_Occurrence_Of (Any_Id, Loc)); - else - Analyze (N); end if; return True; diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 93edfe2df22b..fa365214ee12 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -174,6 +174,7 @@ package body Sem_Res is procedure Resolve_Explicit_Dereference (N : Node_Id; Typ : Entity_Id); procedure Resolve_Expression_With_Actions (N : Node_Id; Typ : Entity_Id); procedure Resolve_If_Expression (N : Node_Id; Typ : Entity_Id); + procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id); procedure Resolve_Indexed_Component (N : Node_Id; Typ : Entity_Id); procedure Resolve_Integer_Literal (N : Node_Id; Typ : Entity_Id); procedure Resolve_Logical_Op (N : Node_Id; Typ : Entity_Id); @@ -2375,7 +2376,15 @@ package body Sem_Res is and then Ekind (It.Nam) = E_Discriminant and then Has_Implicit_Dereference (It.Nam) then - Build_Explicit_Dereference (N, It.Nam); + -- If the node is a general indexing, the dereference is + -- is inserted when resolving the rewritten form, else + -- insert it now. + + if Nkind (N) /= N_Indexed_Component + or else No (Generalized_Indexing (N)) + then + Build_Explicit_Dereference (N, It.Nam); + end if; -- For an explicit dereference, attribute reference, range, -- short-circuit form (which is not an operator node), or call @@ -7520,6 +7529,47 @@ package body Sem_Res is end if; end Resolve_Expression_With_Actions; + ---------------------------------- + -- Resolve_Generalized_Indexing -- + ---------------------------------- + + procedure Resolve_Generalized_Indexing (N : Node_Id; Typ : Entity_Id) is + Indexing : constant Node_Id := Generalized_Indexing (N); + Call : Node_Id; + Indices : List_Id; + Pref : Node_Id; + + begin + + -- In ASIS mode, propagate the information about the indices back to + -- to the original indexing node. The generalized indexing is either + -- a function call, or a dereference of one. The actuals include the + -- prefix of the original node, which is the container expression. + + if ASIS_Mode then + Resolve (Indexing, Typ); + Set_Etype (N, Etype (Indexing)); + Set_Is_Overloaded (N, False); + Call := Indexing; + while Nkind_In (Call, + N_Explicit_Dereference, N_Selected_Component) + loop + Call := Prefix (Call); + end loop; + + if Nkind (Call) = N_Function_Call then + Indices := Parameter_Associations (Call); + Pref := Remove_Head (Indices); + Set_Expressions (N, Indices); + Set_Prefix (N, Pref); + end if; + + else + Rewrite (N, Indexing); + Resolve (N, Typ); + end if; + end Resolve_Generalized_Indexing; + --------------------------- -- Resolve_If_Expression -- --------------------------- @@ -7591,6 +7641,11 @@ package body Sem_Res is Index : Node_Id; begin + if Present (Generalized_Indexing (N)) then + Resolve_Generalized_Indexing (N, Typ); + return; + end if; + if Is_Overloaded (Name) then -- Use the context type to select the prefix that yields the correct diff --git a/gcc/ada/sinfo.adb b/gcc/ada/sinfo.adb index 6140e676e486..dbd54bbdf1ed 100644 --- a/gcc/ada/sinfo.adb +++ b/gcc/ada/sinfo.adb @@ -1399,6 +1399,14 @@ package body Sinfo is return Flag6 (N); end From_Default; + function Generalized_Indexing + (N : Node_Id) return Node_Id is + begin + pragma Assert (False + or else NT (N).Nkind = N_Indexed_Component); + return Node4 (N); + end Generalized_Indexing; + function Generic_Associations (N : Node_Id) return List_Id is begin @@ -4531,6 +4539,14 @@ package body Sinfo is Set_Flag6 (N, Val); end Set_From_Default; + procedure Set_Generalized_Indexing + (N : Node_Id; Val : Node_Id) is + begin + pragma Assert (False + or else NT (N).Nkind = N_Indexed_Component); + Set_Node4 (N, Val); + end Set_Generalized_Indexing; + procedure Set_Generic_Associations (N : Node_Id; Val : List_Id) is begin diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index af476c0da825..e115e7ad707a 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -1277,6 +1277,15 @@ package Sinfo is -- declaration is treated as an implicit reference to the formal in the -- ali file. + -- Generalized_Indexing (Node4-Sem) + -- Generalized_Indexing is set in Indexed_Component nodes that are Ada 2012 + -- container indexing operations. The value of the attribute is a function + -- call (possibly dereferenced) that corresponds to the proper expansion + -- of the source indexing operation. Before expansion, the source node + -- is rewritten as the resolved generalized indexing. In ASIS mode, the + -- expansion does not take place, so that the source is preserved and + -- properly annotated with types. + -- Generic_Parent (Node5-Sem) -- Generic_Parent is defined on declaration nodes that are instances. The -- value of Generic_Parent is the generic entity from which the instance @@ -3470,6 +3479,7 @@ package Sinfo is -- Sloc contains a copy of the Sloc value of the Prefix -- Prefix (Node3) -- Expressions (List1) + -- Generalized_Indexing (Node4-Sem) -- Atomic_Sync_Required (Flag14-Sem) -- plus fields for expression @@ -8912,6 +8922,8 @@ package Sinfo is function From_Default (N : Node_Id) return Boolean; -- Flag6 + function Generalized_Indexing + (N : Node_Id) return Node_Id; -- Node4 function Generic_Associations (N : Node_Id) return List_Id; -- List3 @@ -9908,6 +9920,9 @@ package Sinfo is procedure Set_From_Default (N : Node_Id; Val : Boolean := True); -- Flag6 + procedure Set_Generalized_Indexing + (N : Node_Id; Val : Node_Id); -- Node4 + procedure Set_Generic_Associations (N : Node_Id; Val : List_Id); -- List3 @@ -10918,7 +10933,7 @@ package Sinfo is (1 => True, -- Expressions (List1) 2 => False, -- unused 3 => True, -- Prefix (Node3) - 4 => False, -- unused + 4 => False, -- Generalized_Indexing (Node4-Sem) 5 => False), -- Etype (Node5-Sem) N_Slice => @@ -12372,6 +12387,7 @@ package Sinfo is pragma Inline (From_At_End); pragma Inline (From_At_Mod); pragma Inline (From_Default); + pragma Inline (Generalized_Indexing); pragma Inline (Generic_Associations); pragma Inline (Generic_Formal_Declarations); pragma Inline (Generic_Parent); @@ -12701,6 +12717,7 @@ package Sinfo is pragma Inline (Set_From_At_End); pragma Inline (Set_From_At_Mod); pragma Inline (Set_From_Default); + pragma Inline (Set_Generalized_Indexing); pragma Inline (Set_Generic_Associations); pragma Inline (Set_Generic_Formal_Declarations); pragma Inline (Set_Generic_Parent);