Commit c7d22ee7 by Arnaud Charlet

[multiple changes]

2015-02-05  Robert Dewar  <dewar@adacore.com>

	* prj-proc.adb, sem_aux.adb, exp_ch9.adb, errout.adb, prj-dect.adb,
	prj-nmsc.adb: Minor reformatting.

2015-02-05  Ed Schonberg  <schonberg@adacore.com>

	* sem_type.adb (Covers): In ASIS_Mode the Corresponding_Record
	of a protected type may not be available, so to check conformance
	with an interface type, examine the interface list in the type
	declaration directly.
	(Write_Overloads): Improve information for indirect calls,
	for debugger use.

2015-02-05  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch3.adb (Make_Tag_Assignment): Do not perform this
	expansion activity in ASIS mode.

From-SVN: r220452
parent 273123a4
2015-02-05 Robert Dewar <dewar@adacore.com>
* prj-proc.adb, sem_aux.adb, exp_ch9.adb, errout.adb, prj-dect.adb,
prj-nmsc.adb: Minor reformatting.
2015-02-05 Ed Schonberg <schonberg@adacore.com>
* sem_type.adb (Covers): In ASIS_Mode the Corresponding_Record
of a protected type may not be available, so to check conformance
with an interface type, examine the interface list in the type
declaration directly.
(Write_Overloads): Improve information for indirect calls,
for debugger use.
2015-02-05 Ed Schonberg <schonberg@adacore.com>
* exp_ch3.adb (Make_Tag_Assignment): Do not perform this
expansion activity in ASIS mode.
2015-02-05 Javier Miranda <miranda@adacore.com> 2015-02-05 Javier Miranda <miranda@adacore.com>
* errout.adb (Error_Msg_PT): Add missing error. * errout.adb (Error_Msg_PT): Add missing error.
......
...@@ -689,12 +689,12 @@ package body Errout is ...@@ -689,12 +689,12 @@ package body Errout is
if Ekind (E) = E_Function then if Ekind (E) = E_Function then
Error_Msg_N Error_Msg_N
("\first formal of & declared # must be of mode `IN` " & ("\first formal of & declared # must be of mode `IN` "
"or access-to-constant", E); & "or access-to-constant", E);
else else
Error_Msg_N Error_Msg_N
("\first formal of & declared # must be of mode `OUT`, `IN OUT` " & ("\first formal of & declared # must be of mode `OUT`, `IN OUT` "
"or access-to-variable", E); & "or access-to-variable", E);
end if; end if;
end Error_Msg_PT; end Error_Msg_PT;
......
...@@ -9889,17 +9889,21 @@ package body Exp_Ch3 is ...@@ -9889,17 +9889,21 @@ package body Exp_Ch3 is
New_Ref : Node_Id; New_Ref : Node_Id;
begin begin
-- This expansion activity is called during analysis, but cannot
-- be applied in ASIS mode when other expansion is disabled.
if Is_Tagged_Type (Typ) if Is_Tagged_Type (Typ)
and then not Is_Class_Wide_Type (Typ) and then not Is_Class_Wide_Type (Typ)
and then not Is_CPP_Class (Typ) and then not Is_CPP_Class (Typ)
and then Tagged_Type_Expansion and then Tagged_Type_Expansion
and then Nkind (Expr) /= N_Aggregate and then Nkind (Expr) /= N_Aggregate
and then not ASIS_Mode
and then (Nkind (Expr) /= N_Qualified_Expression and then (Nkind (Expr) /= N_Qualified_Expression
or else Nkind (Expression (Expr)) /= N_Aggregate) or else Nkind (Expression (Expr)) /= N_Aggregate)
then then
New_Ref := New_Ref :=
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Def_If, Loc), Prefix => New_Occurrence_Of (Def_If, Loc),
Selector_Name => Selector_Name =>
New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc)); New_Occurrence_Of (First_Tag_Component (Full_Typ), Loc));
Set_Assignment_OK (New_Ref); Set_Assignment_OK (New_Ref);
......
...@@ -2639,11 +2639,11 @@ package body Exp_Ch9 is ...@@ -2639,11 +2639,11 @@ package body Exp_Ch9 is
if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then if Nkind (Parameter_Type (First_Param)) = N_Access_Definition then
Obj_Param_Typ := Obj_Param_Typ :=
Make_Access_Definition (Loc, Make_Access_Definition (Loc,
Subtype_Mark => Subtype_Mark =>
New_Occurrence_Of (Obj_Typ, Loc), New_Occurrence_Of (Obj_Typ, Loc),
Null_Exclusion_Present => Null_Exclusion_Present =>
Null_Exclusion_Present (Parameter_Type (First_Param)), Null_Exclusion_Present (Parameter_Type (First_Param)),
Constant_Present => Constant_Present =>
Constant_Present (Parameter_Type (First_Param))); Constant_Present (Parameter_Type (First_Param)));
else else
Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc);
......
...@@ -627,9 +627,8 @@ package body Prj.Dect is ...@@ -627,9 +627,8 @@ package body Prj.Dect is
-- Look for the package node -- Look for the package node
while Present (The_Package) while Present (The_Package)
and then and then Name_Of (The_Package, In_Tree) /=
Name_Of (The_Package, In_Tree) /= Token_Name
Token_Name
loop loop
The_Package := The_Package :=
Next_Package_In_Project Next_Package_In_Project
......
...@@ -1803,9 +1803,9 @@ package body Prj.Nmsc is ...@@ -1803,9 +1803,9 @@ package body Prj.Nmsc is
Lang_Index := Get_Language_From_Name Lang_Index := Get_Language_From_Name
(Project, Get_Name_String (Element.Index)); (Project, Get_Name_String (Element.Index));
if Lang_Index /= No_Language_Index and then if Lang_Index /= No_Language_Index
Element.Value.Kind = Single and then and then Element.Value.Kind = Single
Element.Value.Value /= No_Name and then Element.Value.Value /= No_Name
then then
case Current_Array.Name is case Current_Array.Name is
when Name_Spec_Suffix | Name_Specification_Suffix => when Name_Spec_Suffix | Name_Specification_Suffix =>
...@@ -4290,8 +4290,8 @@ package body Prj.Nmsc is ...@@ -4290,8 +4290,8 @@ package body Prj.Nmsc is
Shared => Shared); Shared => Shared);
end if; end if;
if Suffix /= Nil_Variable_Value and then if Suffix /= Nil_Variable_Value
Suffix.Value /= No_Name and then Suffix.Value /= No_Name
then then
Lang_Id.Config.Naming_Data.Spec_Suffix := Lang_Id.Config.Naming_Data.Spec_Suffix :=
File_Name_Type (Suffix.Value); File_Name_Type (Suffix.Value);
...@@ -4325,8 +4325,8 @@ package body Prj.Nmsc is ...@@ -4325,8 +4325,8 @@ package body Prj.Nmsc is
Shared => Shared); Shared => Shared);
end if; end if;
if Suffix /= Nil_Variable_Value and then if Suffix /= Nil_Variable_Value
Suffix.Value /= No_Name and then Suffix.Value /= No_Name
then then
Lang_Id.Config.Naming_Data.Body_Suffix := Lang_Id.Config.Naming_Data.Body_Suffix :=
File_Name_Type (Suffix.Value); File_Name_Type (Suffix.Value);
......
...@@ -547,9 +547,7 @@ package body Prj.Proc is ...@@ -547,9 +547,7 @@ package body Prj.Proc is
case Current_Term_Kind is case Current_Term_Kind is
when N_Literal_String => when N_Literal_String =>
case Kind is case Kind is
when Undefined => when Undefined =>
-- Should never happen -- Should never happen
...@@ -602,7 +600,6 @@ package body Prj.Proc is ...@@ -602,7 +600,6 @@ package body Prj.Proc is
end case; end case;
when N_Literal_String_List => when N_Literal_String_List =>
declare declare
String_Node : Project_Node_Id := String_Node : Project_Node_Id :=
First_Expression_In_List First_Expression_In_List
...@@ -697,7 +694,6 @@ package body Prj.Proc is ...@@ -697,7 +694,6 @@ package body Prj.Proc is
end; end;
when N_Variable_Reference | N_Attribute_Reference => when N_Variable_Reference | N_Attribute_Reference =>
declare declare
The_Project : Project_Id := Project; The_Project : Project_Id := Project;
The_Package : Package_Id := Pkg; The_Package : Package_Id := Pkg;
......
...@@ -981,6 +981,11 @@ package body Sem_Aux is ...@@ -981,6 +981,11 @@ package body Sem_Aux is
if Is_Type (Ent) if Is_Type (Ent)
and then Base_Type (Ent) /= Root_Type (Ent) and then Base_Type (Ent) /= Root_Type (Ent)
and then not Is_Class_Wide_Type (Ent) and then not Is_Class_Wide_Type (Ent)
-- An access_to_subprogram whose result type is a limited view can
-- appear in a return statement, without the full view of the result
-- type being available. Do not interpret this as a derived type.
and then Ekind (Ent) /= E_Subprogram_Type and then Ekind (Ent) /= E_Subprogram_Type
then then
if not Is_Numeric_Type (Root_Type (Ent)) then if not Is_Numeric_Type (Root_Type (Ent)) then
......
...@@ -954,16 +954,43 @@ package body Sem_Type is ...@@ -954,16 +954,43 @@ package body Sem_Type is
-- Note: test for presence of E is defense against previous error. -- Note: test for presence of E is defense against previous error.
if No (E) then if No (E) then
Check_Error_Detected;
-- If expansion is disabled the Corresponding_Record_Type may
-- not be available yet, so use the interface list in the
-- declaration directly.
if ASIS_Mode
and then Nkind (Parent (BT2)) = N_Protected_Type_Declaration
and then Present (Interface_List (Parent (BT2)))
then
declare
Intf : Node_Id := First (Interface_List (Parent (BT2)));
begin
while Present (Intf) loop
if Is_Ancestor (Etype (T1), Entity (Intf)) then
return True;
else
Next (Intf);
end if;
end loop;
end;
return False;
else
Check_Error_Detected;
end if;
-- Here we have a corresponding record type
elsif Present (Interfaces (E)) then elsif Present (Interfaces (E)) then
Elmt := First_Elmt (Interfaces (E)); Elmt := First_Elmt (Interfaces (E));
while Present (Elmt) loop while Present (Elmt) loop
if Is_Ancestor (Etype (T1), Node (Elmt)) then if Is_Ancestor (Etype (T1), Node (Elmt)) then
return True; return True;
else
Next_Elmt (Elmt);
end if; end if;
Next_Elmt (Elmt);
end loop; end loop;
end if; end if;
...@@ -3499,23 +3526,25 @@ package body Sem_Type is ...@@ -3499,23 +3526,25 @@ package body Sem_Type is
Write_Str ("Overloads: "); Write_Str ("Overloads: ");
Print_Node_Briefly (N); Print_Node_Briefly (N);
if Nkind (N) not in N_Has_Entity then
return;
end if;
if not Is_Overloaded (N) then if not Is_Overloaded (N) then
Write_Str ("Non-overloaded entity "); Write_Line ("Non-overloaded entity ");
Write_Eol;
Write_Entity_Info (Entity (N), " "); Write_Entity_Info (Entity (N), " ");
elsif Nkind (N) not in N_Has_Entity then
Get_First_Interp (N, I, It);
while Present (It.Nam) loop
Write_Int (Int (It.Typ));
Write_Str (" ");
Write_Name (Chars (It.Typ));
Write_Eol;
Get_Next_Interp (I, It);
end loop;
else else
Get_First_Interp (N, I, It); Get_First_Interp (N, I, It);
Write_Str ("Overloaded entity "); Write_Line ("Overloaded entity ");
Write_Eol; Write_Line (" Name Type Abstract Op");
Write_Str (" Name Type Abstract Op"); Write_Line ("===============================================");
Write_Eol;
Write_Str ("===============================================");
Write_Eol;
Nam := It.Nam; Nam := It.Nam;
while Present (Nam) loop while Present (Nam) loop
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment