diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 38 | ||||
| -rw-r--r-- | gcc/ada/exp_aggr.adb | 7 | ||||
| -rw-r--r-- | gcc/ada/sem_ch10.adb | 16 | ||||
| -rw-r--r-- | gcc/ada/sem_ch12.adb | 15 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 2 | ||||
| -rw-r--r-- | gcc/ada/sem_ch4.adb | 45 | ||||
| -rw-r--r-- | gcc/ada/sem_ch6.adb | 186 | ||||
| -rw-r--r-- | gcc/ada/sem_res.adb | 38 | ||||
| -rw-r--r-- | gcc/ada/tracebak.c | 3 |
9 files changed, 261 insertions, 89 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 3dcc02d1672..05f1f2bb559 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,41 @@ +2016-04-21 Hristian Kirtchev <kirtchev@adacore.com> + + * sem_ch3.adb: Code cleanup. + * sem_ch6.adb: Code cleanup. + (Is_Matching_Limited_View): New routine. + (Matches_Limited_With_View): Reimplemented. + * sem_ch10.adb (Decorate_Type): Code cleanup. + +2016-04-21 Doug Rupp <rupp@adacore.com> + + * tracebak.c (PPC ELF): Add macro defs for lynxos178e. + +2016-04-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch4.adb (Try_Container_Indexing): If there are overloaded + indexing functions, collect all overloadings of the call firts, + and then transfer them to indexing node, to prevent interleaving + of the set of interpretations of the nodes involved. + * sem_res.adb (Resolve): Suppress cascaded errors that report + ambiguities when one of the actuals in an overloaded generatlized + indexing operation is illegal and has type Any_Type, as is done + for similar cascaded errors in subprogram calls. + (Valid_Tagged_Conversion): Cleanup conversion checks when one + of the types involved is a class-wide subtype. + +2016-04-21 Ed Schonberg <schonberg@adacore.com> + + * sem_ch12.adb (Load_Parent_Of_Generic): When looking for the + subprogram declaration within a wrapper package, skip pragmas + that may have been generated by aspect specifications on the + generic instance. + +2016-04-21 Javier Miranda <miranda@adacore.com> + + * exp_aggr.adb (Component_Not_OK_For_Backend): Generating C + code return True for array identifiers since the backend needs + to initialize such component by means of memcpy(). + 2016-04-21 Arnaud Charlet <charlet@adacore.com> * a-tasatt.adb, a-tasatt.ads (Fast_Path): Rewritten to avoid reading diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index c6b6210fd28..19ecdad9745 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -6061,6 +6061,13 @@ package body Exp_Aggr is then Static_Components := False; return True; + + elsif Modify_Tree_For_C + and then Nkind (Expr_Q) = N_Identifier + and then Is_Array_Type (Etype (Expr_Q)) + then + Static_Components := False; + return True; end if; if Is_Elementary_Type (Etype (Expr_Q)) then diff --git a/gcc/ada/sem_ch10.adb b/gcc/ada/sem_ch10.adb index da5aba8c1b9..c872abed6ae 100644 --- a/gcc/ada/sem_ch10.adb +++ b/gcc/ada/sem_ch10.adb @@ -5637,10 +5637,10 @@ package body Sem_Ch10 is Set_Ekind (Ent, E_Incomplete_Type); Set_Etype (Ent, Ent); - Set_Scope (Ent, Scop); + Set_Full_View (Ent, Empty); Set_Is_First_Subtype (Ent); + Set_Scope (Ent, Scop); Set_Stored_Constraint (Ent, No_Elist); - Set_Full_View (Ent, Empty); Init_Size_Align (Ent); -- A tagged type and its corresponding shadow entity share one common @@ -5668,16 +5668,16 @@ package body Sem_Ch10 is Set_Parent (CW_Typ, Parent (Ent)); Set_Ekind (CW_Typ, E_Class_Wide_Type); - Set_Etype (CW_Typ, Ent); - Set_Scope (CW_Typ, Scop); - Set_Is_Tagged_Type (CW_Typ); - Set_Is_First_Subtype (CW_Typ); - Init_Size_Align (CW_Typ); - Set_Has_Unknown_Discriminants (CW_Typ); Set_Class_Wide_Type (CW_Typ, CW_Typ); + Set_Etype (CW_Typ, Ent); Set_Equivalent_Type (CW_Typ, Empty); Set_From_Limited_With (CW_Typ, From_Limited_With (Ent)); + Set_Has_Unknown_Discriminants (CW_Typ); + Set_Is_First_Subtype (CW_Typ); + Set_Is_Tagged_Type (CW_Typ); Set_Materialize_Entity (CW_Typ, Materialize); + Set_Scope (CW_Typ, Scop); + Init_Size_Align (CW_Typ); end if; end Decorate_Type; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 1d4d5c0bdf6..699ad690892 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -13105,18 +13105,23 @@ package body Sem_Ch12 is -- The instance_spec is in the wrapper package, -- usually followed by its local renaming -- declaration. See Build_Subprogram_Renaming - -- for details. + -- for details. If the instance carries aspects, + -- these result in the corresponding pragmas, + -- inserted after the subprogram declaration. + -- They must be skipped as well when retrieving + -- the desired spec. A direct link would be + -- more robust ??? declare Decl : Node_Id := (Last (Visible_Declarations (Specification (Info.Act_Decl)))); begin - if Nkind (Decl) = - N_Subprogram_Renaming_Declaration - then + while Nkind_In (Decl, + N_Subprogram_Renaming_Declaration, N_Pragma) + loop Decl := Prev (Decl); - end if; + end loop; Info.Act_Decl := Decl; end; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 0560a69f564..bbb10ac4edf 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5074,7 +5074,7 @@ package body Sem_Ch3 is -- inherit static and dynamic predicates if any. -- If declaration has no aspect specifications, inherit predicate - -- info as well. Unclear how to handle the case of both specified + -- info as well. Unclear how to handle the case of both specified -- and inherited predicates ??? Other inherited aspects, such as -- invariants, should be OK, but the combination with later pragmas -- may also require special merging. diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 6ba51e8f3d8..5b463cbd29a 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -7537,27 +7537,54 @@ package body Sem_Ch4 is Get_First_Interp (Func_Name, I, It); Set_Etype (Indexing, Any_Type); + -- Analyze eacn candidae function with the given actuals + while Present (It.Nam) loop Analyze_One_Call (Indexing, It.Nam, False, Success); + Get_Next_Interp (I, It); + end loop; - if Success then + -- If there are several successful candidates, resolution will + -- be by result. Mark the interpretations of the function name + -- itself. - -- Function in current interpretation is a valid candidate. - -- Its result type is also a potential type for the - -- original Indexed_Component node. + if Is_Overloaded (Indexing) then + Get_First_Interp (Indexing, I, It); + while Present (It.Nam) loop Add_One_Interp (Name (Indexing), It.Nam, It.Typ); + Get_Next_Interp (I, It); + end loop; + + else + Set_Etype (Name (Indexing), Etype (Indexing)); + end if; + + -- Now add the candidate interpretations to the indexing node + -- itself, to be replaced later by the function call. + + if Is_Overloaded (Name (Indexing)) then + Get_First_Interp (Name (Indexing), I, It); + + while Present (It.Nam) loop Add_One_Interp (N, It.Nam, It.Typ); - -- Add implicit dereference interpretation to original node + -- Add dereference interpretation if the result type type + -- has implicit reference discriminants. if Has_Discriminants (Etype (It.Nam)) then Check_Implicit_Dereference (N, Etype (It.Nam)); end if; - end if; - Get_Next_Interp (I, It); - end loop; + Get_Next_Interp (I, It); + end loop; + + else + Set_Etype (N, Etype (Name (Indexing))); + if Has_Discriminants (Etype (N)) then + Check_Implicit_Dereference (N, Etype (N)); + end if; + end if; end; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 1a996da0db8..6c5e56a666c 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -6482,45 +6482,48 @@ package body Sem_Ch6 is Ctype : Conformance_Type; Get_Inst : Boolean := False) return Boolean is - Type_1 : Entity_Id := T1; - Type_2 : Entity_Id := T2; - Are_Anonymous_Access_To_Subprogram_Types : Boolean := False; - - function Base_Types_Match (T1, T2 : Entity_Id) return Boolean; - -- If neither T1 nor T2 are generic actual types, or if they are in - -- different scopes (e.g. parent and child instances), then verify that - -- the base types are equal. Otherwise T1 and T2 must be on the same - -- subtype chain. The whole purpose of this procedure is to prevent - -- spurious ambiguities in an instantiation that may arise if two - -- distinct generic types are instantiated with the same actual. - - function Find_Designated_Type (T : Entity_Id) return Entity_Id; + function Base_Types_Match + (Typ_1 : Entity_Id; + Typ_2 : Entity_Id) return Boolean; + -- If neither Typ_1 nor Typ_2 are generic actual types, or if they are + -- in different scopes (e.g. parent and child instances), then verify + -- that the base types are equal. Otherwise Typ_1 and Typ_2 must be on + -- the same subtype chain. The whole purpose of this procedure is to + -- prevent spurious ambiguities in an instantiation that may arise if + -- two distinct generic types are instantiated with the same actual. + + function Find_Designated_Type (Typ : Entity_Id) return Entity_Id; -- An access parameter can designate an incomplete type. If the -- incomplete type is the limited view of a type from a limited_ - -- with_clause, check whether the non-limited view is available. If - -- it is a (non-limited) incomplete type, get the full view. - - function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean; - -- Returns True if and only if either T1 denotes a limited view of T2 - -- or T2 denotes a limited view of T1. This can arise when the limited - -- with view of a type is used in a subprogram declaration and the - -- subprogram body is in the scope of a regular with clause for the - -- same unit. In such a case, the two type entities can be considered + -- with_clause, check whether the non-limited view is available. + -- If it is a (non-limited) incomplete type, get the full view. + + function Matches_Limited_With_View + (Typ_1 : Entity_Id; + Typ_2 : Entity_Id) return Boolean; + -- Returns True if and only if either Typ_1 denotes a limited view of + -- Typ_2 or Typ_2 denotes a limited view of Typ_1. This can arise when + -- the limited with view of a type is used in a subprogram declaration + -- and the subprogram body is in the scope of a regular with clause for + -- the same unit. In such a case, the two type entities are considered -- identical for purposes of conformance checking. ---------------------- -- Base_Types_Match -- ---------------------- - function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is - BT1 : constant Entity_Id := Base_Type (T1); - BT2 : constant Entity_Id := Base_Type (T2); + function Base_Types_Match + (Typ_1 : Entity_Id; + Typ_2 : Entity_Id) return Boolean + is + Base_1 : constant Entity_Id := Base_Type (Typ_1); + Base_2 : constant Entity_Id := Base_Type (Typ_2); begin - if T1 = T2 then + if Typ_1 = Typ_2 then return True; - elsif BT1 = BT2 then + elsif Base_1 = Base_2 then -- The following is too permissive. A more precise test should -- check that the generic actual is an ancestor subtype of the @@ -6529,18 +6532,23 @@ package body Sem_Ch6 is -- See code in Find_Corresponding_Spec that applies an additional -- filter to handle accidental amiguities in instances. - return not Is_Generic_Actual_Type (T1) - or else not Is_Generic_Actual_Type (T2) - or else Scope (T1) /= Scope (T2); + return + not Is_Generic_Actual_Type (Typ_1) + or else not Is_Generic_Actual_Type (Typ_2) + or else Scope (Typ_1) /= Scope (Typ_2); - -- If T2 is a generic actual type it is declared as the subtype of + -- If Typ_2 is a generic actual type it is declared as the subtype of -- the actual. If that actual is itself a subtype we need to use its -- own base type to check for compatibility. - elsif Ekind (BT2) = Ekind (T2) and then BT1 = Base_Type (BT2) then + elsif Ekind (Base_2) = Ekind (Typ_2) + and then Base_1 = Base_Type (Base_2) + then return True; - elsif Ekind (BT1) = Ekind (T1) and then BT2 = Base_Type (BT1) then + elsif Ekind (Base_1) = Ekind (Typ_1) + and then Base_2 = Base_Type (Base_1) + then return True; else @@ -6552,11 +6560,11 @@ package body Sem_Ch6 is -- Find_Designated_Type -- -------------------------- - function Find_Designated_Type (T : Entity_Id) return Entity_Id is + function Find_Designated_Type (Typ : Entity_Id) return Entity_Id is Desig : Entity_Id; begin - Desig := Directly_Designated_Type (T); + Desig := Directly_Designated_Type (Typ); if Ekind (Desig) = E_Incomplete_Type then @@ -6580,39 +6588,115 @@ package body Sem_Ch6 is -- Matches_Limited_With_View -- ------------------------------- - function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean is + function Matches_Limited_With_View + (Typ_1 : Entity_Id; + Typ_2 : Entity_Id) return Boolean + is + function Is_Matching_Limited_View + (Typ : Entity_Id; + View : Entity_Id) return Boolean; + -- Determine whether non-limited view View denotes type Typ in some + -- conformant fashion. + + ------------------------------ + -- Is_Matching_Limited_View -- + ------------------------------ + + function Is_Matching_Limited_View + (Typ : Entity_Id; + View : Entity_Id) return Boolean + is + Root_Typ : Entity_Id; + Root_View : Entity_Id; + + begin + -- The non-limited view directly denotes the type + + if Typ = View then + return True; + + -- The type is a subtype of the non-limited view + + elsif Is_Subtype_Of (Typ, View) then + return True; + + -- Both the non-limited view and the type denote class-wide types + + elsif Is_Class_Wide_Type (Typ) + and then Is_Class_Wide_Type (View) + then + Root_Typ := Root_Type (Typ); + Root_View := Root_Type (View); + + if Root_Typ = Root_View then + return True; + + -- An incomplete tagged type and its full view may receive two + -- distinct class-wide types when the related package has not + -- been analyzed yet. + + -- package Pack is + -- type T is tagged; -- CW_1 + -- type T is tagged null record; -- CW_2 + -- end Pack; + + -- This is because the package lacks any semantic information + -- that may eventually link both views of T. As a consequence, + -- a client of the limited view of Pack will see CW_2 while a + -- client of the non-limited view of Pack will see CW_1. + + elsif Is_Incomplete_Type (Root_Typ) + and then Present (Full_View (Root_Typ)) + and then Full_View (Root_Typ) = Root_View + then + return True; + + elsif Is_Incomplete_Type (Root_View) + and then Present (Full_View (Root_View)) + and then Full_View (Root_View) = Root_Typ + then + return True; + end if; + end if; + + return False; + end Is_Matching_Limited_View; + + -- Start of processing for Matches_Limited_With_View + begin -- In some cases a type imported through a limited_with clause, and - -- its nonlimited view are both visible, for example in an anonymous + -- its non-limited view are both visible, for example in an anonymous -- access-to-class-wide type in a formal, or when building the body -- for a subprogram renaming after the subprogram has been frozen. - -- In these cases Both entities designate the same type. In addition, + -- In these cases both entities designate the same type. In addition, -- if one of them is an actual in an instance, it may be a subtype of -- the non-limited view of the other. - if From_Limited_With (T1) - and then (T2 = Available_View (T1) - or else Is_Subtype_Of (T2, Available_View (T1))) + if From_Limited_With (Typ_1) + and then From_Limited_With (Typ_2) + and then Available_View (Typ_1) = Available_View (Typ_2) then return True; - elsif From_Limited_With (T2) - and then (T1 = Available_View (T2) - or else Is_Subtype_Of (T1, Available_View (T2))) - then - return True; + elsif From_Limited_With (Typ_1) then + return Is_Matching_Limited_View (Typ_2, Available_View (Typ_1)); - elsif From_Limited_With (T1) - and then From_Limited_With (T2) - and then Available_View (T1) = Available_View (T2) - then - return True; + elsif From_Limited_With (Typ_2) then + return Is_Matching_Limited_View (Typ_1, Available_View (Typ_2)); else return False; end if; end Matches_Limited_With_View; + -- Local variables + + Are_Anonymous_Access_To_Subprogram_Types : Boolean := False; + + Type_1 : Entity_Id := T1; + Type_2 : Entity_Id := T2; + -- Start of processing for Conforming_Types begin diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 8957287dbfd..c6effa379de 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2248,17 +2248,25 @@ package body Sem_Res is end loop; else - -- Before we issue an ambiguity complaint, check for - -- the case of a subprogram call where at least one - -- of the arguments is Any_Type, and if so, suppress - -- the message, since it is a cascaded error. - - if Nkind (N) in N_Subprogram_Call then + -- Before we issue an ambiguity complaint, check for the + -- case of a subprogram call where at least one of the + -- arguments is Any_Type, and if so suppress the message, + -- since it is a cascaded error. This can also happen for + -- a generalized indexing operation. + + if Nkind (N) in N_Subprogram_Call + or else (Nkind (N) = N_Indexed_Component + and then Present (Generalized_Indexing (N))) + then declare A : Node_Id; E : Node_Id; begin + if Nkind (N) = N_Indexed_Component then + Rewrite (N, Generalized_Indexing (N)); + end if; + A := First_Actual (N); while Present (A) loop E := A; @@ -2292,17 +2300,17 @@ package body Sem_Res is exit Interp_Loop; end if; - -- Not that special case, so issue message using the - -- flag Ambiguous to control printing of the header - -- message only at the start of an ambiguous set. + -- Not that special case, so issue message using the flag + -- Ambiguous to control printing of the header message + -- only at the start of an ambiguous set. if not Ambiguous then if Nkind (N) = N_Function_Call and then Nkind (Name (N)) = N_Explicit_Dereference then Error_Msg_N - ("ambiguous expression " - & "(cannot resolve indirect call)!", N); + ("ambiguous expression (cannot resolve indirect " + & "call)!", N); else Error_Msg_NE -- CODEFIX ("ambiguous expression (cannot resolve&)!", @@ -11836,9 +11844,11 @@ package body Sem_Res is "downward conversion of tagged objects not allowed"); -- Ada 2005 (AI-251): The conversion to/from interface types is - -- always valid + -- always valid. The types involved may be class-wide (sub)types. - elsif Is_Interface (Target_Type) or else Is_Interface (Opnd_Type) then + elsif Is_Interface (Etype (Base_Type (Target_Type))) + or else Is_Interface (Etype (Base_Type (Opnd_Type))) + then return True; -- If the operand is a class-wide type obtained through a limited_ diff --git a/gcc/ada/tracebak.c b/gcc/ada/tracebak.c index dceac0d443b..7b1849bdf03 100644 --- a/gcc/ada/tracebak.c +++ b/gcc/ada/tracebak.c @@ -354,9 +354,10 @@ extern void __runnit(); /* thread entry point. */ #define BASE_SKIP 1 -/*-------------------- PPC ELF (GNU/Linux & VxWorks) ---------------------*/ +/*----------- PPC ELF (GNU/Linux & VxWorks & Lynx178e) -------------------*/ #elif (defined (_ARCH_PPC) && defined (__vxworks)) || \ + (defined (__powerpc__) && defined (__Lynx__) && defined(__ELF__)) || \ (defined (__linux__) && defined (__powerpc__)) #define USE_GENERIC_UNWINDER |