Skip to content

R
riscv-gcc-1
Commit 273123a4 by Arnaud Charlet
Options

[multiple changes] 

2015-02-05  Javier Miranda  <miranda@adacore.com>

	* errout.adb (Error_Msg_PT): Add missing error.
	* sem_ch6.adb (Check_Synchronized_Overriding): Check the missing
	RM rule.  Code cleanup.
	* exp_ch9.adb (Build_Wrapper_Spec): Propagate "constant" in
	anonymous access types.  Found working on the tests. Code cleanup.

2015-02-05  Vincent Celier  <celier@adacore.com>

	* prj-dect.adb (Parse_Attribute_Declaration): Continue scanning
	when there are incomplete withs.
	* prj-nmsc.adb (Process_Naming): Do not try to get the value
	of an element when it is nil.
	(Check_Naming): Do not check a nil suffix for illegality
	* prj-proc.adb (Expression): Do not process an empty term.
	* prj-strt.adb (Attribute_Reference): If attribute cannot be
	found, parse a possible index to avoid cascading errors.

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

	* sem_aux.adb (Is_Derived_Type): A subprogram_type generated
	for an access_to_subprogram declaration is not a derived type.

From-SVN: r220451
parent ee7c8ffd
Showing with 141 additions and 86 deletions
gcc/ada/ChangeLog
2015-02-05 Javier Miranda <miranda@adacore.com>
* errout.adb (Error_Msg_PT): Add missing error.
* sem_ch6.adb (Check_Synchronized_Overriding): Check the missing
RM rule. Code cleanup.
* exp_ch9.adb (Build_Wrapper_Spec): Propagate "constant" in
anonymous access types. Found working on the tests. Code cleanup.
2015-02-05 Vincent Celier <celier@adacore.com>
* prj-dect.adb (Parse_Attribute_Declaration): Continue scanning
when there are incomplete withs.
* prj-nmsc.adb (Process_Naming): Do not try to get the value
of an element when it is nil.
(Check_Naming): Do not check a nil suffix for illegality
* prj-proc.adb (Expression): Do not process an empty term.
* prj-strt.adb (Attribute_Reference): If attribute cannot be
found, parse a possible index to avoid cascading errors.
2015-02-05 Ed Schonberg <schonberg@adacore.com>
* sem_aux.adb (Is_Derived_Type): A subprogram_type generated
for an access_to_subprogram declaration is not a derived type.
2015-02-05 Robert Dewar <dewar@adacore.com> 2015-02-05 Robert Dewar <dewar@adacore.com>
* errout.adb (Error_Msg_Internal): For non-serious error set * errout.adb (Error_Msg_Internal): For non-serious error set
......
gcc/ada/errout.adb
...@@ -686,9 +686,16 @@ package body Errout is ...@@ -686,9 +686,16 @@ package body Errout is
("illegal overriding of subprogram inherited from interface", E); ("illegal overriding of subprogram inherited from interface", E);
Error_Msg_Sloc := Sloc (Iface_Prim); Error_Msg_Sloc := Sloc (Iface_Prim);
Error_Msg_N
("\first formal of & declared # must be of mode `OUT`, `IN OUT` " & if Ekind (E) = E_Function then
"or access-to-variable", E); Error_Msg_N
("\first formal of & declared # must be of mode `IN` " &
"or access-to-constant", E);
else
Error_Msg_N
("\first formal of & declared # must be of mode `OUT`, `IN OUT` " &
"or access-to-variable", E);
end if;
end Error_Msg_PT; end Error_Msg_PT;
----------------- -----------------
......
gcc/ada/exp_ch9.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2015, 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- --
...@@ -2640,10 +2640,11 @@ package body Exp_Ch9 is ...@@ -2640,10 +2640,11 @@ package body Exp_Ch9 is
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),
Set_Null_Exclusion_Present (Obj_Param_Typ, Null_Exclusion_Present =>
Null_Exclusion_Present (Parameter_Type (First_Param))); Null_Exclusion_Present (Parameter_Type (First_Param)),
Constant_Present =>
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);
end if; end if;
......
gcc/ada/prj-dect.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2015, 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- --
...@@ -582,7 +582,7 @@ package body Prj.Dect is ...@@ -582,7 +582,7 @@ package body Prj.Dect is
The_Project := Imported_Or_Extended_Project_Of The_Project := Imported_Or_Extended_Project_Of
(Current_Project, In_Tree, Token_Name); (Current_Project, In_Tree, Token_Name);
if No (The_Project) then if No (The_Project) and then not In_Tree.Incomplete_With then
Error_Msg (Flags, "unknown project", Location); Error_Msg (Flags, "unknown project", Location);
Scan (In_Tree); -- past the project name Scan (In_Tree); -- past the project name
...@@ -617,33 +617,37 @@ package body Prj.Dect is ...@@ -617,33 +617,37 @@ package body Prj.Dect is
Get_Name_String Get_Name_String
(Name_Of (Current_Package, In_Tree)), (Name_Of (Current_Package, In_Tree)),
Token_Ptr); Token_Ptr);
Scan (In_Tree); -- past the package name
else else
The_Package := if Present (The_Project) then
First_Package_Of (The_Project, In_Tree);
-- Look for the package node
while Present (The_Package)
and then
Name_Of (The_Package, In_Tree) /= Token_Name
loop
The_Package := The_Package :=
Next_Package_In_Project First_Package_Of (The_Project, In_Tree);
(The_Package, In_Tree);
end loop; -- Look for the package node
-- If the package cannot be found in the while Present (The_Package)
-- project, issue an error. and then
Name_Of (The_Package, In_Tree) /=
if No (The_Package) then Token_Name
The_Project := Empty_Node; loop
Error_Msg_Name_2 := Project_Name; The_Package :=
Error_Msg_Name_1 := Token_Name; Next_Package_In_Project
Error_Msg (The_Package, In_Tree);
(Flags, end loop;
"package % not declared in project %",
Token_Ptr); -- If the package cannot be found in the
-- project, issue an error.
if No (The_Package) then
The_Project := Empty_Node;
Error_Msg_Name_2 := Project_Name;
Error_Msg_Name_1 := Token_Name;
Error_Msg
(Flags,
"package % not declared in project %",
Token_Ptr);
end if;
end if; end if;
Scan (In_Tree); -- past the package name Scan (In_Tree); -- past the package name
...@@ -653,7 +657,7 @@ package body Prj.Dect is ...@@ -653,7 +657,7 @@ package body Prj.Dect is
end if; end if;
end if; end if;
if Present (The_Project) then if Present (The_Project) or else In_Tree.Incomplete_With then
-- Looking for '<same attribute name> -- Looking for '<same attribute name>
......
gcc/ada/prj-nmsc.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2000-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2000-2015, 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- --
...@@ -1803,7 +1803,10 @@ package body Prj.Nmsc is ...@@ -1803,7 +1803,10 @@ 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 then if Lang_Index /= No_Language_Index and then
Element.Value.Kind = Single and then
Element.Value.Value /= No_Name
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 =>
...@@ -4287,7 +4290,9 @@ package body Prj.Nmsc is ...@@ -4287,7 +4290,9 @@ package body Prj.Nmsc is
Shared => Shared); Shared => Shared);
end if; end if;
if Suffix /= Nil_Variable_Value then if Suffix /= Nil_Variable_Value and then
Suffix.Value /= No_Name
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);
...@@ -4320,7 +4325,9 @@ package body Prj.Nmsc is ...@@ -4320,7 +4325,9 @@ package body Prj.Nmsc is
Shared => Shared); Shared => Shared);
end if; end if;
if Suffix /= Nil_Variable_Value then if Suffix /= Nil_Variable_Value and then
Suffix.Value /= No_Name
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);
......
gcc/ada/prj-proc.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2015, 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- --
...@@ -539,10 +539,12 @@ package body Prj.Proc is ...@@ -539,10 +539,12 @@ package body Prj.Proc is
The_Term := First_Term; The_Term := First_Term;
while Present (The_Term) loop while Present (The_Term) loop
The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree); The_Current_Term := Current_Term (The_Term, From_Project_Node_Tree);
Current_Term_Kind :=
Kind_Of (The_Current_Term, From_Project_Node_Tree);
case Current_Term_Kind is if The_Current_Term /= Empty_Node then
Current_Term_Kind :=
Kind_Of (The_Current_Term, From_Project_Node_Tree);
case Current_Term_Kind is
when N_Literal_String => when N_Literal_String =>
...@@ -578,7 +580,7 @@ package body Prj.Proc is ...@@ -578,7 +580,7 @@ package body Prj.Proc is
else else
Shared.String_Elements.Table Shared.String_Elements.Table
(Last).Next := String_Element_Table.Last (Last).Next := String_Element_Table.Last
(Shared.String_Elements); (Shared.String_Elements);
end if; end if;
Last := String_Element_Table.Last Last := String_Element_Table.Last
...@@ -586,8 +588,8 @@ package body Prj.Proc is ...@@ -586,8 +588,8 @@ package body Prj.Proc is
Shared.String_Elements.Table (Last) := Shared.String_Elements.Table (Last) :=
(Value => String_Value_Of (Value => String_Value_Of
(The_Current_Term, (The_Current_Term,
From_Project_Node_Tree), From_Project_Node_Tree),
Index => Source_Index_Of Index => Source_Index_Of
(The_Current_Term, (The_Current_Term,
From_Project_Node_Tree), From_Project_Node_Tree),
...@@ -743,7 +745,7 @@ package body Prj.Proc is ...@@ -743,7 +745,7 @@ package body Prj.Proc is
The_Package := The_Project.Decl.Packages; The_Package := The_Project.Decl.Packages;
while The_Package /= No_Package while The_Package /= No_Package
and then Shared.Packages.Table (The_Package).Name /= and then Shared.Packages.Table (The_Package).Name /=
The_Name The_Name
loop loop
The_Package := The_Package :=
Shared.Packages.Table (The_Package).Next; Shared.Packages.Table (The_Package).Next;
...@@ -753,7 +755,7 @@ package body Prj.Proc is ...@@ -753,7 +755,7 @@ package body Prj.Proc is
(The_Package /= No_Package, "package not found."); (The_Package /= No_Package, "package not found.");
elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) = elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) =
N_Attribute_Reference N_Attribute_Reference
then then
The_Package := No_Package; The_Package := No_Package;
end if; end if;
...@@ -886,8 +888,8 @@ package body Prj.Proc is ...@@ -886,8 +888,8 @@ package body Prj.Proc is
else else
if Expression_Kind_Of if Expression_Kind_Of
(The_Current_Term, From_Project_Node_Tree) = (The_Current_Term, From_Project_Node_Tree) =
List List
then then
The_Variable := The_Variable :=
(Project => Project, (Project => Project,
...@@ -1047,8 +1049,8 @@ package body Prj.Proc is ...@@ -1047,8 +1049,8 @@ package body Prj.Proc is
else else
Shared.String_Elements.Table (Last).Next := Shared.String_Elements.Table (Last).Next :=
String_Element_Table.Last String_Element_Table.Last
(Shared.String_Elements); (Shared.String_Elements);
end if; end if;
Last := Last :=
...@@ -1059,8 +1061,8 @@ package body Prj.Proc is ...@@ -1059,8 +1061,8 @@ package body Prj.Proc is
(Value => The_Variable.Value, (Value => The_Variable.Value,
Display_Value => No_Name, Display_Value => No_Name,
Location => Location_Of Location => Location_Of
(The_Current_Term, (The_Current_Term,
From_Project_Node_Tree), From_Project_Node_Tree),
Flag => False, Flag => False,
Next => Nil_String, Next => Nil_String,
Index => 0); Index => 0);
...@@ -1108,7 +1110,7 @@ package body Prj.Proc is ...@@ -1108,7 +1110,7 @@ package body Prj.Proc is
Index => 0); Index => 0);
The_List := Shared.String_Elements.Table The_List := Shared.String_Elements.Table
(The_List).Next; (The_List).Next;
end loop; end loop;
end; end;
end case; end case;
...@@ -1334,10 +1336,10 @@ package body Prj.Proc is ...@@ -1334,10 +1336,10 @@ package body Prj.Proc is
String_Element_Table.Increment_Last String_Element_Table.Increment_Last
(Shared.String_Elements); (Shared.String_Elements);
Shared.String_Elements.Table (Last).Next := Shared.String_Elements.Table (Last).Next :=
String_Element_Table.Last String_Element_Table.Last
(Shared.String_Elements); (Shared.String_Elements);
Last := String_Element_Table.Last Last := String_Element_Table.Last
(Shared.String_Elements); (Shared.String_Elements);
end if; end if;
end loop; end loop;
...@@ -1366,7 +1368,8 @@ package body Prj.Proc is ...@@ -1366,7 +1368,8 @@ package body Prj.Proc is
"illegal node kind in an expression"); "illegal node kind in an expression");
raise Program_Error; raise Program_Error;
end case; end case;
end if;
The_Term := Next_Term (The_Term, From_Project_Node_Tree); The_Term := Next_Term (The_Term, From_Project_Node_Tree);
end loop; end loop;
......
gcc/ada/prj-strt.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 2001-2014, Free Software Foundation, Inc. -- -- Copyright (C) 2001-2015, 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- --
...@@ -207,6 +207,20 @@ package body Prj.Strt is ...@@ -207,6 +207,20 @@ package body Prj.Strt is
Scan (In_Tree); Scan (In_Tree);
-- Skip a possible index for an associative array
if Token = Tok_Left_Paren then
Scan (In_Tree);
if Token = Tok_String_Literal then
Scan (In_Tree);
if Token = Tok_Right_Paren then
Scan (In_Tree);
end if;
end if;
end if;
else else
-- Give its characteristics to this attribute reference -- Give its characteristics to this attribute reference
......
gcc/ada/sem_aux.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- B o d y --
-- -- -- --
-- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- -- Copyright (C) 1992-2015, 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- --
...@@ -981,6 +981,7 @@ package body Sem_Aux is ...@@ -981,6 +981,7 @@ 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)
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
return True; return True;
......
gcc/ada/sem_ch6.adb
...@@ -9259,7 +9259,6 @@ package body Sem_Ch6 is ...@@ -9259,7 +9259,6 @@ package body Sem_Ch6 is
declare declare
Candidate : Entity_Id := Empty; Candidate : Entity_Id := Empty;
Hom : Entity_Id := Empty; Hom : Entity_Id := Empty;
Iface_Typ : Entity_Id;
Subp : Entity_Id := Empty; Subp : Entity_Id := Empty;
begin begin
...@@ -9334,8 +9333,23 @@ package body Sem_Ch6 is ...@@ -9334,8 +9333,23 @@ package body Sem_Ch6 is
and then Etype (Result_Definition (Parent (Def_Id))) = and then Etype (Result_Definition (Parent (Def_Id))) =
Etype (Result_Definition (Parent (Subp))) Etype (Result_Definition (Parent (Subp)))
then then
Overridden_Subp := Subp; Candidate := Subp;
return;
-- If an inherited subprogram is implemented by a protected
-- function, then the first parameter of the inherited
-- subprogram shall be of mode in, but not an
-- access-to-variable parameter (RM 9.4(11/9)
if Present (First_Formal (Subp))
and then Ekind (First_Formal (Subp)) = E_In_Parameter
and then
(not Is_Access_Type (Etype (First_Formal (Subp)))
or else
Is_Access_Constant (Etype (First_Formal (Subp))))
then
Overridden_Subp := Subp;
return;
end if;
end if; end if;
Hom := Homonym (Hom); Hom := Homonym (Hom);
...@@ -9343,29 +9357,9 @@ package body Sem_Ch6 is ...@@ -9343,29 +9357,9 @@ package body Sem_Ch6 is
-- After examining all candidates for overriding, we are left with -- After examining all candidates for overriding, we are left with
-- the best match which is a mode incompatible interface routine. -- the best match which is a mode incompatible interface routine.
-- Do not emit an error if the Expander is active since this error
-- will be detected later on after all concurrent types are
-- expanded and all wrappers are built. This check is meant for
-- spec-only compilations.
if Present (Candidate) and then not Expander_Active then
Iface_Typ :=
Find_Parameter_Type (Parent (First_Formal (Candidate)));
-- Def_Id is primitive of a protected type, declared inside the
-- type, and the candidate is primitive of a limited or
-- synchronized interface.
if In_Scope if In_Scope and then Present (Candidate) then
and then Is_Protected_Type (Typ) Error_Msg_PT (Def_Id, Candidate);
and then
(Is_Limited_Interface (Iface_Typ)
or else Is_Protected_Interface (Iface_Typ)
or else Is_Synchronized_Interface (Iface_Typ)
or else Is_Task_Interface (Iface_Typ))
then
Error_Msg_PT (Def_Id, Candidate);
end if;
end if; end if;
Overridden_Subp := Candidate; Overridden_Subp := Candidate;
......
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