[multiple changes]

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().

From-SVN: r235330
This commit is contained in:
Arnaud Charlet 2016-04-21 12:25:59 +02:00
parent 150346bd8d
commit 0310af44bb
9 changed files with 259 additions and 87 deletions

View file

@ -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> 2016-04-21 Arnaud Charlet <charlet@adacore.com>
* a-tasatt.adb, a-tasatt.ads (Fast_Path): Rewritten to avoid reading * a-tasatt.adb, a-tasatt.ads (Fast_Path): Rewritten to avoid reading

View file

@ -6061,6 +6061,13 @@ package body Exp_Aggr is
then then
Static_Components := False; Static_Components := False;
return True; 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; end if;
if Is_Elementary_Type (Etype (Expr_Q)) then if Is_Elementary_Type (Etype (Expr_Q)) then

View file

@ -5637,10 +5637,10 @@ package body Sem_Ch10 is
Set_Ekind (Ent, E_Incomplete_Type); Set_Ekind (Ent, E_Incomplete_Type);
Set_Etype (Ent, Ent); Set_Etype (Ent, Ent);
Set_Scope (Ent, Scop);
Set_Is_First_Subtype (Ent);
Set_Stored_Constraint (Ent, No_Elist);
Set_Full_View (Ent, Empty); Set_Full_View (Ent, Empty);
Set_Is_First_Subtype (Ent);
Set_Scope (Ent, Scop);
Set_Stored_Constraint (Ent, No_Elist);
Init_Size_Align (Ent); Init_Size_Align (Ent);
-- A tagged type and its corresponding shadow entity share one common -- 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_Parent (CW_Typ, Parent (Ent));
Set_Ekind (CW_Typ, E_Class_Wide_Type); 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_Class_Wide_Type (CW_Typ, CW_Typ);
Set_Etype (CW_Typ, Ent);
Set_Equivalent_Type (CW_Typ, Empty); Set_Equivalent_Type (CW_Typ, Empty);
Set_From_Limited_With (CW_Typ, From_Limited_With (Ent)); 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_Materialize_Entity (CW_Typ, Materialize);
Set_Scope (CW_Typ, Scop);
Init_Size_Align (CW_Typ);
end if; end if;
end Decorate_Type; end Decorate_Type;

View file

@ -13105,18 +13105,23 @@ package body Sem_Ch12 is
-- The instance_spec is in the wrapper package, -- The instance_spec is in the wrapper package,
-- usually followed by its local renaming -- usually followed by its local renaming
-- declaration. See Build_Subprogram_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 declare
Decl : Node_Id := Decl : Node_Id :=
(Last (Visible_Declarations (Last (Visible_Declarations
(Specification (Info.Act_Decl)))); (Specification (Info.Act_Decl))));
begin begin
if Nkind (Decl) = while Nkind_In (Decl,
N_Subprogram_Renaming_Declaration N_Subprogram_Renaming_Declaration, N_Pragma)
then loop
Decl := Prev (Decl); Decl := Prev (Decl);
end if; end loop;
Info.Act_Decl := Decl; Info.Act_Decl := Decl;
end; end;

View file

@ -5074,7 +5074,7 @@ package body Sem_Ch3 is
-- inherit static and dynamic predicates if any. -- inherit static and dynamic predicates if any.
-- If declaration has no aspect specifications, inherit predicate -- 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 -- and inherited predicates ??? Other inherited aspects, such as
-- invariants, should be OK, but the combination with later pragmas -- invariants, should be OK, but the combination with later pragmas
-- may also require special merging. -- may also require special merging.

View file

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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); Get_First_Interp (Func_Name, I, It);
Set_Etype (Indexing, Any_Type); Set_Etype (Indexing, Any_Type);
-- Analyze eacn candidae function with the given actuals
while Present (It.Nam) loop while Present (It.Nam) loop
Analyze_One_Call (Indexing, It.Nam, False, Success); 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. if Is_Overloaded (Indexing) then
-- Its result type is also a potential type for the Get_First_Interp (Indexing, I, It);
-- original Indexed_Component node.
while Present (It.Nam) loop
Add_One_Interp (Name (Indexing), It.Nam, It.Typ); 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_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 if Has_Discriminants (Etype (It.Nam)) then
Check_Implicit_Dereference (N, Etype (It.Nam)); Check_Implicit_Dereference (N, Etype (It.Nam));
end if; end if;
end if;
Get_Next_Interp (I, It); Get_Next_Interp (I, It);
end loop; 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;
end if; end if;

View file

@ -6482,45 +6482,48 @@ package body Sem_Ch6 is
Ctype : Conformance_Type; Ctype : Conformance_Type;
Get_Inst : Boolean := False) return Boolean Get_Inst : Boolean := False) return Boolean
is is
Type_1 : Entity_Id := T1; function Base_Types_Match
Type_2 : Entity_Id := T2; (Typ_1 : Entity_Id;
Are_Anonymous_Access_To_Subprogram_Types : Boolean := False; 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 Base_Types_Match (T1, T2 : Entity_Id) return Boolean; function Find_Designated_Type (Typ : Entity_Id) return Entity_Id;
-- 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;
-- An access parameter can designate an incomplete type. If the -- An access parameter can designate an incomplete type. If the
-- incomplete type is the limited view of a type from a limited_ -- incomplete type is the limited view of a type from a limited_
-- with_clause, check whether the non-limited view is available. If -- with_clause, check whether the non-limited view is available.
-- it is a (non-limited) incomplete type, get the full view. -- If it is a (non-limited) incomplete type, get the full view.
function Matches_Limited_With_View (T1, T2 : Entity_Id) return Boolean; function Matches_Limited_With_View
-- Returns True if and only if either T1 denotes a limited view of T2 (Typ_1 : Entity_Id;
-- or T2 denotes a limited view of T1. This can arise when the limited Typ_2 : Entity_Id) return Boolean;
-- with view of a type is used in a subprogram declaration and the -- Returns True if and only if either Typ_1 denotes a limited view of
-- subprogram body is in the scope of a regular with clause for the -- Typ_2 or Typ_2 denotes a limited view of Typ_1. This can arise when
-- same unit. In such a case, the two type entities can be considered -- 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. -- identical for purposes of conformance checking.
---------------------- ----------------------
-- Base_Types_Match -- -- Base_Types_Match --
---------------------- ----------------------
function Base_Types_Match (T1, T2 : Entity_Id) return Boolean is function Base_Types_Match
BT1 : constant Entity_Id := Base_Type (T1); (Typ_1 : Entity_Id;
BT2 : constant Entity_Id := Base_Type (T2); 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 begin
if T1 = T2 then if Typ_1 = Typ_2 then
return True; return True;
elsif BT1 = BT2 then elsif Base_1 = Base_2 then
-- The following is too permissive. A more precise test should -- The following is too permissive. A more precise test should
-- check that the generic actual is an ancestor subtype of the -- 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 -- See code in Find_Corresponding_Spec that applies an additional
-- filter to handle accidental amiguities in instances. -- filter to handle accidental amiguities in instances.
return not Is_Generic_Actual_Type (T1) return
or else not Is_Generic_Actual_Type (T2) not Is_Generic_Actual_Type (Typ_1)
or else Scope (T1) /= Scope (T2); 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 -- the actual. If that actual is itself a subtype we need to use its
-- own base type to check for compatibility. -- 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; 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; return True;
else else
@ -6552,11 +6560,11 @@ package body Sem_Ch6 is
-- Find_Designated_Type -- -- 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; Desig : Entity_Id;
begin begin
Desig := Directly_Designated_Type (T); Desig := Directly_Designated_Type (Typ);
if Ekind (Desig) = E_Incomplete_Type then if Ekind (Desig) = E_Incomplete_Type then
@ -6580,39 +6588,115 @@ package body Sem_Ch6 is
-- Matches_Limited_With_View -- -- 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 begin
-- In some cases a type imported through a limited_with clause, and -- 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 -- access-to-class-wide type in a formal, or when building the body
-- for a subprogram renaming after the subprogram has been frozen. -- 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 -- if one of them is an actual in an instance, it may be a subtype of
-- the non-limited view of the other. -- the non-limited view of the other.
if From_Limited_With (T1) if From_Limited_With (Typ_1)
and then (T2 = Available_View (T1) and then From_Limited_With (Typ_2)
or else Is_Subtype_Of (T2, Available_View (T1))) and then Available_View (Typ_1) = Available_View (Typ_2)
then then
return True; return True;
elsif From_Limited_With (T2) elsif From_Limited_With (Typ_1) then
and then (T1 = Available_View (T2) return Is_Matching_Limited_View (Typ_2, Available_View (Typ_1));
or else Is_Subtype_Of (T1, Available_View (T2)))
then
return True;
elsif From_Limited_With (T1) elsif From_Limited_With (Typ_2) then
and then From_Limited_With (T2) return Is_Matching_Limited_View (Typ_1, Available_View (Typ_2));
and then Available_View (T1) = Available_View (T2)
then
return True;
else else
return False; return False;
end if; end if;
end Matches_Limited_With_View; 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 -- Start of processing for Conforming_Types
begin begin

View file

@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
@ -2248,17 +2248,25 @@ package body Sem_Res is
end loop; end loop;
else else
-- Before we issue an ambiguity complaint, check for -- Before we issue an ambiguity complaint, check for the
-- the case of a subprogram call where at least one -- case of a subprogram call where at least one of the
-- of the arguments is Any_Type, and if so, suppress -- arguments is Any_Type, and if so suppress the message,
-- the message, since it is a cascaded error. -- since it is a cascaded error. This can also happen for
-- a generalized indexing operation.
if Nkind (N) in N_Subprogram_Call then if Nkind (N) in N_Subprogram_Call
or else (Nkind (N) = N_Indexed_Component
and then Present (Generalized_Indexing (N)))
then
declare declare
A : Node_Id; A : Node_Id;
E : Node_Id; E : Node_Id;
begin begin
if Nkind (N) = N_Indexed_Component then
Rewrite (N, Generalized_Indexing (N));
end if;
A := First_Actual (N); A := First_Actual (N);
while Present (A) loop while Present (A) loop
E := A; E := A;
@ -2292,17 +2300,17 @@ package body Sem_Res is
exit Interp_Loop; exit Interp_Loop;
end if; end if;
-- Not that special case, so issue message using the -- Not that special case, so issue message using the flag
-- flag Ambiguous to control printing of the header -- Ambiguous to control printing of the header message
-- message only at the start of an ambiguous set. -- only at the start of an ambiguous set.
if not Ambiguous then if not Ambiguous then
if Nkind (N) = N_Function_Call if Nkind (N) = N_Function_Call
and then Nkind (Name (N)) = N_Explicit_Dereference and then Nkind (Name (N)) = N_Explicit_Dereference
then then
Error_Msg_N Error_Msg_N
("ambiguous expression " ("ambiguous expression (cannot resolve indirect "
& "(cannot resolve indirect call)!", N); & "call)!", N);
else else
Error_Msg_NE -- CODEFIX Error_Msg_NE -- CODEFIX
("ambiguous expression (cannot resolve&)!", ("ambiguous expression (cannot resolve&)!",
@ -11836,9 +11844,11 @@ package body Sem_Res is
"downward conversion of tagged objects not allowed"); "downward conversion of tagged objects not allowed");
-- Ada 2005 (AI-251): The conversion to/from interface types is -- 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; return True;
-- If the operand is a class-wide type obtained through a limited_ -- If the operand is a class-wide type obtained through a limited_

View file

@ -354,9 +354,10 @@ extern void __runnit(); /* thread entry point. */
#define BASE_SKIP 1 #define BASE_SKIP 1
/*-------------------- PPC ELF (GNU/Linux & VxWorks) ---------------------*/ /*----------- PPC ELF (GNU/Linux & VxWorks & Lynx178e) -------------------*/
#elif (defined (_ARCH_PPC) && defined (__vxworks)) || \ #elif (defined (_ARCH_PPC) && defined (__vxworks)) || \
(defined (__powerpc__) && defined (__Lynx__) && defined(__ELF__)) || \
(defined (__linux__) && defined (__powerpc__)) (defined (__linux__) && defined (__powerpc__))
#define USE_GENERIC_UNWINDER #define USE_GENERIC_UNWINDER