From 273123a48a42b08a87cacdfe665848c143716ef1 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 5 Feb 2015 15:32:46 +0100 Subject: [PATCH] [multiple changes] 2015-02-05 Javier Miranda * 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 * 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 * sem_aux.adb (Is_Derived_Type): A subprogram_type generated for an access_to_subprogram declaration is not a derived type. From-SVN: r220451 --- gcc/ada/ChangeLog | 24 ++++++++++++++++++++ gcc/ada/errout.adb | 13 ++++++++--- gcc/ada/exp_ch9.adb | 11 +++++---- gcc/ada/prj-dect.adb | 54 ++++++++++++++++++++++++-------------------- gcc/ada/prj-nmsc.adb | 15 ++++++++---- gcc/ada/prj-proc.adb | 43 +++++++++++++++++++---------------- gcc/ada/prj-strt.adb | 16 ++++++++++++- gcc/ada/sem_aux.adb | 3 ++- gcc/ada/sem_ch6.adb | 44 ++++++++++++++++-------------------- 9 files changed, 139 insertions(+), 84 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 6da97c7b27c..d9ef29a2ca7 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2015-02-05 Javier Miranda + + * 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 + + * 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 + + * 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 * errout.adb (Error_Msg_Internal): For non-serious error set diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 86ea13f6fbb..d79cafa0926 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -686,9 +686,16 @@ package body Errout is ("illegal overriding of subprogram inherited from interface", E); Error_Msg_Sloc := Sloc (Iface_Prim); - Error_Msg_N - ("\first formal of & declared # must be of mode `OUT`, `IN OUT` " & - "or access-to-variable", E); + + if Ekind (E) = E_Function then + 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; ----------------- diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 4674da70f8a..9d467c31e54 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -2640,10 +2640,11 @@ package body Exp_Ch9 is Obj_Param_Typ := Make_Access_Definition (Loc, Subtype_Mark => - New_Occurrence_Of (Obj_Typ, Loc)); - Set_Null_Exclusion_Present (Obj_Param_Typ, - Null_Exclusion_Present (Parameter_Type (First_Param))); - + New_Occurrence_Of (Obj_Typ, Loc), + Null_Exclusion_Present => + Null_Exclusion_Present (Parameter_Type (First_Param)), + Constant_Present => + Constant_Present (Parameter_Type (First_Param))); else Obj_Param_Typ := New_Occurrence_Of (Obj_Typ, Loc); end if; diff --git a/gcc/ada/prj-dect.adb b/gcc/ada/prj-dect.adb index 672c45419a9..e0f6dcb7944 100644 --- a/gcc/ada/prj-dect.adb +++ b/gcc/ada/prj-dect.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -582,7 +582,7 @@ package body Prj.Dect is The_Project := Imported_Or_Extended_Project_Of (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); Scan (In_Tree); -- past the project name @@ -617,33 +617,37 @@ package body Prj.Dect is Get_Name_String (Name_Of (Current_Package, In_Tree)), Token_Ptr); + Scan (In_Tree); -- past the package name else - The_Package := - 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 + if Present (The_Project) then The_Package := - Next_Package_In_Project - (The_Package, In_Tree); - end loop; + First_Package_Of (The_Project, In_Tree); - -- If the package cannot be found in the - -- project, issue an error. + -- Look for the package node - 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); + while Present (The_Package) + and then + Name_Of (The_Package, In_Tree) /= + Token_Name + loop + The_Package := + Next_Package_In_Project + (The_Package, In_Tree); + end loop; + + -- 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; Scan (In_Tree); -- past the package name @@ -653,7 +657,7 @@ package body Prj.Dect is end if; end if; - if Present (The_Project) then + if Present (The_Project) or else In_Tree.Incomplete_With then -- Looking for ' diff --git a/gcc/ada/prj-nmsc.adb b/gcc/ada/prj-nmsc.adb index 3bfe2d837ed..9c7a8d0c687 100644 --- a/gcc/ada/prj-nmsc.adb +++ b/gcc/ada/prj-nmsc.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -1803,7 +1803,10 @@ package body Prj.Nmsc is Lang_Index := Get_Language_From_Name (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 when Name_Spec_Suffix | Name_Specification_Suffix => @@ -4287,7 +4290,9 @@ package body Prj.Nmsc is Shared => Shared); 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 := File_Name_Type (Suffix.Value); @@ -4320,7 +4325,9 @@ package body Prj.Nmsc is Shared => Shared); 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 := File_Name_Type (Suffix.Value); diff --git a/gcc/ada/prj-proc.adb b/gcc/ada/prj-proc.adb index ac2cc66ce31..0107aa0a45e 100644 --- a/gcc/ada/prj-proc.adb +++ b/gcc/ada/prj-proc.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -539,10 +539,12 @@ package body Prj.Proc is The_Term := First_Term; while Present (The_Term) loop 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 => @@ -578,7 +580,7 @@ package body Prj.Proc is else Shared.String_Elements.Table (Last).Next := String_Element_Table.Last - (Shared.String_Elements); + (Shared.String_Elements); end if; Last := String_Element_Table.Last @@ -586,8 +588,8 @@ package body Prj.Proc is Shared.String_Elements.Table (Last) := (Value => String_Value_Of - (The_Current_Term, - From_Project_Node_Tree), + (The_Current_Term, + From_Project_Node_Tree), Index => Source_Index_Of (The_Current_Term, From_Project_Node_Tree), @@ -743,7 +745,7 @@ package body Prj.Proc is The_Package := The_Project.Decl.Packages; while The_Package /= No_Package and then Shared.Packages.Table (The_Package).Name /= - The_Name + The_Name loop The_Package := Shared.Packages.Table (The_Package).Next; @@ -753,7 +755,7 @@ package body Prj.Proc is (The_Package /= No_Package, "package not found."); elsif Kind_Of (The_Current_Term, From_Project_Node_Tree) = - N_Attribute_Reference + N_Attribute_Reference then The_Package := No_Package; end if; @@ -886,8 +888,8 @@ package body Prj.Proc is else if Expression_Kind_Of - (The_Current_Term, From_Project_Node_Tree) = - List + (The_Current_Term, From_Project_Node_Tree) = + List then The_Variable := (Project => Project, @@ -1047,8 +1049,8 @@ package body Prj.Proc is else Shared.String_Elements.Table (Last).Next := - String_Element_Table.Last - (Shared.String_Elements); + String_Element_Table.Last + (Shared.String_Elements); end if; Last := @@ -1059,8 +1061,8 @@ package body Prj.Proc is (Value => The_Variable.Value, Display_Value => No_Name, Location => Location_Of - (The_Current_Term, - From_Project_Node_Tree), + (The_Current_Term, + From_Project_Node_Tree), Flag => False, Next => Nil_String, Index => 0); @@ -1108,7 +1110,7 @@ package body Prj.Proc is Index => 0); The_List := Shared.String_Elements.Table - (The_List).Next; + (The_List).Next; end loop; end; end case; @@ -1334,10 +1336,10 @@ package body Prj.Proc is String_Element_Table.Increment_Last (Shared.String_Elements); Shared.String_Elements.Table (Last).Next := - String_Element_Table.Last - (Shared.String_Elements); + String_Element_Table.Last + (Shared.String_Elements); Last := String_Element_Table.Last - (Shared.String_Elements); + (Shared.String_Elements); end if; end loop; @@ -1366,7 +1368,8 @@ package body Prj.Proc is "illegal node kind in an expression"); raise Program_Error; - end case; + end case; + end if; The_Term := Next_Term (The_Term, From_Project_Node_Tree); end loop; diff --git a/gcc/ada/prj-strt.adb b/gcc/ada/prj-strt.adb index a6b0b381ff2..8956e97a149 100644 --- a/gcc/ada/prj-strt.adb +++ b/gcc/ada/prj-strt.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -207,6 +207,20 @@ package body Prj.Strt is 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 -- Give its characteristics to this attribute reference diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 68104b906ff..09dcc6c6b44 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -6,7 +6,7 @@ -- -- -- 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 -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -981,6 +981,7 @@ package body Sem_Aux is if Is_Type (Ent) and then Base_Type (Ent) /= Root_Type (Ent) and then not Is_Class_Wide_Type (Ent) + and then Ekind (Ent) /= E_Subprogram_Type then if not Is_Numeric_Type (Root_Type (Ent)) then return True; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 575f0b68039..94249faad3e 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -9259,7 +9259,6 @@ package body Sem_Ch6 is declare Candidate : Entity_Id := Empty; Hom : Entity_Id := Empty; - Iface_Typ : Entity_Id; Subp : Entity_Id := Empty; begin @@ -9334,8 +9333,23 @@ package body Sem_Ch6 is and then Etype (Result_Definition (Parent (Def_Id))) = Etype (Result_Definition (Parent (Subp))) then - Overridden_Subp := Subp; - return; + Candidate := Subp; + + -- 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; Hom := Homonym (Hom); @@ -9343,29 +9357,9 @@ package body Sem_Ch6 is -- After examining all candidates for overriding, we are left with -- 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 - and then Is_Protected_Type (Typ) - 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; + if In_Scope and then Present (Candidate) then + Error_Msg_PT (Def_Id, Candidate); end if; Overridden_Subp := Candidate;