From 20250fb87c79d840eb23c51bbe63467910c14fd9 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Mon, 20 Jun 2016 14:31:47 +0200 Subject: [PATCH] [multiple changes] 2016-06-20 Hristian Kirtchev * make.adb, gnatbind.adb, g-socket.adb, sem_ch13.adb: Minor reformatting. * lib.ads, sem_util.adb: Minor typo in comment. 2016-06-20 Yannick Moy * sem_prag.adb, sem_prag.ads (Build_Pragma_Check_Equivalent): Add parameter Keep_Pragma_Id to optionally keep the identifier of the pragma instead of converting to pragma Check. Also set type of new function call appropriately. (Collect_Inherited_Class_Wide_Conditions): Call Build_Pragma_Check_Equivalent with the new parameter Keep_Pragma_Id set to True to keep the identifier of the copied pragma. * sinfo.ads: Add comment. 2016-06-20 Hristian Kirtchev * exp_ch7.adb (Build_Invariant_Procedure_Body): Always install the scope of the invariant procedure in order to produce better error messages. Do not insert the body when the context is a generic unit. (Build_Invariant_Procedure_Declaration): Perform minimal decoration of the invariant procedure and its formal parameter in case they are not analyzed. Do not insert the declaration when the context is a generic unit. From-SVN: r237600 --- gcc/ada/ChangeLog | 29 ++++++++++++ gcc/ada/exp_ch7.adb | 102 +++++++++++++++++++++++++++++++------------ gcc/ada/g-socket.adb | 17 ++++---- gcc/ada/gnatbind.adb | 3 +- gcc/ada/lib.ads | 4 +- gcc/ada/make.adb | 3 +- gcc/ada/sem_ch13.adb | 56 +++++++++++++----------- gcc/ada/sem_prag.adb | 39 ++++++++++++----- gcc/ada/sem_prag.ads | 20 +++++---- gcc/ada/sem_util.adb | 2 +- gcc/ada/sinfo.ads | 4 ++ 11 files changed, 190 insertions(+), 89 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0f7c8352082..4987a23808f 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2016-06-20 Hristian Kirtchev + + * make.adb, gnatbind.adb, g-socket.adb, sem_ch13.adb: Minor + reformatting. + * lib.ads, sem_util.adb: Minor typo in comment. + +2016-06-20 Yannick Moy + + * sem_prag.adb, sem_prag.ads (Build_Pragma_Check_Equivalent): + Add parameter Keep_Pragma_Id to optionally keep + the identifier of the pragma instead of converting + to pragma Check. Also set type of new function call + appropriately. (Collect_Inherited_Class_Wide_Conditions): + Call Build_Pragma_Check_Equivalent with the new parameter + Keep_Pragma_Id set to True to keep the identifier of the copied + pragma. + * sinfo.ads: Add comment. + +2016-06-20 Hristian Kirtchev + + * exp_ch7.adb (Build_Invariant_Procedure_Body): + Always install the scope of the invariant procedure + in order to produce better error messages. Do not + insert the body when the context is a generic unit. + (Build_Invariant_Procedure_Declaration): Perform minimal + decoration of the invariant procedure and its formal parameter + in case they are not analyzed. Do not insert the declaration + when the context is a generic unit. + 2016-06-20 Ed Schonberg * sem_ch13.adb (Visible_Component): New procedure, subsidiary diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index c76d7af3708..b962fcc78a0 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -4622,7 +4622,16 @@ package body Exp_Ch7 is Set_Ghost_Mode_From_Entity (Work_Typ); + -- Emulate the environment of the invariant procedure by installing + -- its scope and formal parameters. Note that this is not need, but + -- having the scope of the invariant procedure installed helps with + -- the detection of invariant-related errors. + + Push_Scope (Proc_Id); + Install_Formals (Proc_Id); + Obj_Id := First_Formal (Proc_Id); + pragma Assert (Present (Obj_Id)); -- The "partial" invariant procedure verifies the invariants of the -- partial view only. @@ -4631,14 +4640,6 @@ package body Exp_Ch7 is pragma Assert (Present (Priv_Typ)); Freeze_Typ := Priv_Typ; - -- Emulate the environment of the invariant procedure by installing - -- its scope and formal parameters. Note that this is not need, but - -- having the scope of the invariant procedure installed helps with - -- the detection of invariant-related errors. - - Push_Scope (Proc_Id); - Install_Formals (Proc_Id); - Add_Type_Invariants (Priv_Typ => Priv_Typ, Full_Typ => Empty, @@ -4646,8 +4647,6 @@ package body Exp_Ch7 is Obj_Id => Obj_Id, Checks => Stmts); - End_Scope; - -- Otherwise the "full" invariant procedure verifies the invariants of -- the full view, all array or record components, as well as class-wide -- invariants inherited from parent types or interfaces. In addition, it @@ -4744,6 +4743,8 @@ package body Exp_Ch7 is Add_Interface_Invariants (Full_Typ, Obj_Id, Stmts); end if; + End_Scope; + -- At this point there should be at least one invariant check. If this -- is not the case, then the invariant-related flags were not properly -- set, or there is a missing invariant procedure on one of the array @@ -4759,6 +4760,12 @@ package body Exp_Ch7 is Stmts := New_List (Make_Null_Statement (Loc)); end if; + -- Generate: + -- procedure [Partial_]Invariant (_object : ) is + -- begin + -- + -- end [Partial_]Invariant; + Proc_Body := Make_Subprogram_Body (Loc, Specification => @@ -4769,16 +4776,30 @@ package body Exp_Ch7 is Statements => Stmts)); Proc_Body_Id := Defining_Entity (Proc_Body); + -- Perform minor decoration in case the body is not analyzed + Set_Ekind (Proc_Body_Id, E_Subprogram_Body); Set_Etype (Proc_Body_Id, Standard_Void_Type); - Set_Scope (Proc_Body_Id, Scope (Typ)); + Set_Scope (Proc_Body_Id, Current_Scope); -- Link both spec and body to avoid generating duplicates Set_Corresponding_Body (Proc_Decl, Proc_Body_Id); Set_Corresponding_Spec (Proc_Body, Proc_Id); - Append_Freeze_Action (Freeze_Typ, Proc_Body); + -- The body should not be inserted into the tree when the context is a + -- generic unit because it is not part of the template. Note that the + -- body must still be generated in order to resolve the invariants. + + if Inside_A_Generic then + null; + + -- Otherwise the body is part of the freezing actions of the type + + else + Append_Freeze_Action (Freeze_Typ, Proc_Body); + end if; + Ghost_Mode := Save_Ghost_Mode; end Build_Invariant_Procedure_Body; @@ -4794,8 +4815,10 @@ package body Exp_Ch7 is Save_Ghost_Mode : constant Ghost_Mode_Type := Ghost_Mode; - Proc_Id : Entity_Id; - Typ_Decl : Node_Id; + Proc_Decl : Node_Id; + Proc_Id : Entity_Id; + Proc_Nam : Name_Id; + Typ_Decl : Node_Id; CRec_Typ : Entity_Id; -- The corresponding record type of Full_Typ @@ -4869,24 +4892,27 @@ package body Exp_Ch7 is -- procedure. if Partial_Invariant then - Proc_Id := - Make_Defining_Identifier (Loc, - Chars => - New_External_Name (Chars (Work_Typ), "Partial_Invariant")); - - Set_Ekind (Proc_Id, E_Procedure); - Set_Is_Partial_Invariant_Procedure (Proc_Id); - Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id); + Proc_Nam := New_External_Name (Chars (Work_Typ), "Partial_Invariant"); -- Otherwise the caller requests the declaration of the "full" invariant -- procedure. else - Proc_Id := - Make_Defining_Identifier (Loc, - Chars => New_External_Name (Chars (Work_Typ), "Invariant")); + Proc_Nam := New_External_Name (Chars (Work_Typ), "Invariant"); + end if; + + Proc_Id := Make_Defining_Identifier (Loc, Chars => Proc_Nam); + + -- Perform minor decoration in case the declaration is not analyzed - Set_Ekind (Proc_Id, E_Procedure); + Set_Ekind (Proc_Id, E_Procedure); + Set_Etype (Proc_Id, Standard_Void_Type); + Set_Scope (Proc_Id, Current_Scope); + + if Partial_Invariant then + Set_Is_Partial_Invariant_Procedure (Proc_Id); + Set_Partial_Invariant_Procedure (Work_Typ, Proc_Id); + else Set_Is_Invariant_Procedure (Proc_Id); Set_Invariant_Procedure (Work_Typ, Proc_Id); end if; @@ -4938,12 +4964,19 @@ package body Exp_Ch7 is -- of the current type instance. Obj_Id := Make_Defining_Identifier (Loc, Chars => Name_uObject); + + -- Perform minor decoration in case the declaration is not analyzed + Set_Ekind (Obj_Id, E_In_Parameter); + Set_Etype (Obj_Id, Work_Typ); + Set_Scope (Obj_Id, Proc_Id); + + Set_First_Entity (Proc_Id, Obj_Id); -- Generate: -- procedure [Partial_]Invariant (_object : ); - Insert_After_And_Analyze (Typ_Decl, + Proc_Decl := Make_Subprogram_Declaration (Loc, Specification => Make_Procedure_Specification (Loc, @@ -4952,7 +4985,20 @@ package body Exp_Ch7 is Make_Parameter_Specification (Loc, Defining_Identifier => Obj_Id, Parameter_Type => - New_Occurrence_Of (Work_Typ, Loc)))))); + New_Occurrence_Of (Work_Typ, Loc))))); + + -- The declaration should not be inserted into the tree when the context + -- is a generic unit because it is not part of the template. + + if Inside_A_Generic then + null; + + -- Otherwise insert the declaration + + else + pragma Assert (Present (Typ_Decl)); + Insert_After_And_Analyze (Typ_Decl, Proc_Decl); + end if; Ghost_Mode := Save_Ghost_Mode; end Build_Invariant_Procedure_Declaration; diff --git a/gcc/ada/g-socket.adb b/gcc/ada/g-socket.adb index a4a7d4f467d..75dc58de1a8 100644 --- a/gcc/ada/g-socket.adb +++ b/gcc/ada/g-socket.adb @@ -1505,27 +1505,26 @@ package body GNAT.Sockets is function Is_IP_Address (Name : String) return Boolean is Dots : Natural := 0; + begin - -- Perform a cursory check for a dotted quad: we must have 1 to 3 - -- dots, and there must be at least one digit around each. + -- Perform a cursory check for a dotted quad: we must have 1 to 3 dots, + -- and there must be at least one digit around each. for J in Name'Range loop if Name (J) = '.' then - -- Check that the dot is not in first or last position, and - -- that it is followed by a digit. Note that we already know - -- that it is preceded by a digit, or we would have returned - -- earlier on. + -- Check that the dot is not in first or last position, and that + -- it is followed by a digit. Note that we already know that it is + -- preceded by a digit, or we would have returned earlier on. if J in Name'First + 1 .. Name'Last - 1 and then Name (J + 1) in '0' .. '9' then Dots := Dots + 1; - else - - -- Definitely not a proper dotted quad + -- Definitely not a proper dotted quad + else return False; end if; diff --git a/gcc/ada/gnatbind.adb b/gcc/ada/gnatbind.adb index 1fa489a22df..85f670716bd 100644 --- a/gcc/ada/gnatbind.adb +++ b/gcc/ada/gnatbind.adb @@ -90,7 +90,7 @@ procedure Gnatbind is -- only with switch -R. procedure Add_Artificial_ALI_File (Name : String); - -- Artificially add ALI file Name in the closure. + -- Artificially add ALI file Name in the closure function Gnatbind_Supports_Auto_Init return Boolean; -- Indicates if automatic initialization of elaboration procedure @@ -123,6 +123,7 @@ procedure Gnatbind is procedure Add_Artificial_ALI_File (Name : String) is Id : ALI_Id; pragma Warnings (Off, Id); + begin Name_Len := Name'Length; Name_Buffer (1 .. Name_Len) := Name; diff --git a/gcc/ada/lib.ads b/gcc/ada/lib.ads index 2f0ccca1e3b..0738cd73e2c 100644 --- a/gcc/ada/lib.ads +++ b/gcc/ada/lib.ads @@ -261,7 +261,7 @@ package Lib is ----------------- -- The units table has an entry for each unit (source file) read in by the - -- current compilation. The table is indexed by the unit number value, + -- current compilation. The table is indexed by the unit number value. -- The first entry in the table, subscript Main_Unit, is for the main file. -- Each entry in this units table contains the following data. @@ -286,7 +286,7 @@ package Lib is -- Dynamic_Elab -- A flag indicating if this unit was compiled with dynamic elaboration -- checks specified (as the result of using the -gnatE compilation - -- option or a pragma Elaboration_Checks (Dynamic). + -- option or a pragma Elaboration_Checks (Dynamic)). -- Error_Location -- This is copied from the Sloc field of the Enode argument passed diff --git a/gcc/ada/make.adb b/gcc/ada/make.adb index c0bde7365b7..9c8d5361ffe 100644 --- a/gcc/ada/make.adb +++ b/gcc/ada/make.adb @@ -2703,7 +2703,6 @@ package body Make is procedure Check_Standard_Library is begin Need_To_Check_Standard_Library := False; - Name_Len := 0; if not Targparm.Suppress_Standard_Library_On_Target then @@ -2713,8 +2712,8 @@ package body Make is end if; declare - Sfile : File_Name_Type; Add_It : Boolean := True; + Sfile : File_Name_Type; begin Sfile := Name_Enter; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 9d2a0bdd25a..06367aff002 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -12312,13 +12312,10 @@ package body Sem_Ch13 is function Replace_Type_Ref (N : Node_Id) return Traverse_Result is Loc : constant Source_Ptr := Sloc (N); - C : Entity_Id; - S : Entity_Id; - P : Node_Id; procedure Add_Prefix (Ref : Node_Id; Comp : Entity_Id); - -- Add the proper prefix to a reference to a component of the - -- type when it is not already a selected component. + -- Add the proper prefix to a reference to a component of the type + -- when it is not already a selected component. ---------------- -- Add_Prefix -- @@ -12328,11 +12325,17 @@ package body Sem_Ch13 is begin Rewrite (Ref, Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (T, Loc), + Prefix => New_Occurrence_Of (T, Loc), Selector_Name => New_Occurrence_Of (Comp, Loc))); Replace_Type_Reference (Prefix (Ref)); end Add_Prefix; + -- Local variables + + Comp : Entity_Id; + Pref : Node_Id; + Scop : Entity_Id; + -- Start of processing for Replace_Type_Ref begin @@ -12363,17 +12366,17 @@ package body Sem_Ch13 is elsif Nkind (Parent (N)) = N_Indexed_Component and then N = Prefix (Parent (N)) then - C := Visible_Component (Chars (N)); + Comp := Visible_Component (Chars (N)); - if Present (C) and then Is_Array_Type (Etype (C)) then - Add_Prefix (N, C); + if Present (Comp) and then Is_Array_Type (Etype (Comp)) then + Add_Prefix (N, Comp); end if; else - C := Visible_Component (Chars (N)); + Comp := Visible_Component (Chars (N)); - if Present (C) then - Add_Prefix (N, C); + if Present (Comp) then + Add_Prefix (N, Comp); end if; end if; @@ -12404,20 +12407,20 @@ package body Sem_Ch13 is else -- Loop through scopes and prefixes, doing comparison - S := Current_Scope; - P := Prefix (N); + Scop := Current_Scope; + Pref := Prefix (N); loop -- Continue if no more scopes or scope with no name - if No (S) or else Nkind (S) not in N_Has_Chars then + if No (Scop) or else Nkind (Scop) not in N_Has_Chars then return OK; end if; -- Do replace if prefix is an identifier matching the scope -- that we are currently looking at. - if Nkind (P) = N_Identifier - and then Chars (P) = Chars (S) + if Nkind (Pref) = N_Identifier + and then Chars (Pref) = Chars (Scop) then Replace_Type_Reference (N); return Skip; @@ -12427,12 +12430,12 @@ package body Sem_Ch13 is -- of a selected component, whose selector matches the scope -- we are currently looking at. - if Nkind (P) = N_Selected_Component - and then Nkind (Selector_Name (P)) = N_Identifier - and then Chars (Selector_Name (P)) = Chars (S) + if Nkind (Pref) = N_Selected_Component + and then Nkind (Selector_Name (Pref)) = N_Identifier + and then Chars (Selector_Name (Pref)) = Chars (Scop) then - S := Scope (S); - P := Prefix (P); + Scop := Scope (Scop); + Pref := Prefix (Pref); -- For anything else, we don't have a match, so keep on -- going, there are still some weird cases where we may @@ -12451,12 +12454,15 @@ package body Sem_Ch13 is end if; end Replace_Type_Ref; + procedure Replace_Type_Refs is new Traverse_Proc (Replace_Type_Ref); + ----------------------- -- Visible_Component -- ----------------------- function Visible_Component (Comp : Name_Id) return Entity_Id is E : Entity_Id; + begin if Ekind (T) /= E_Record_Type then return Empty; @@ -12464,9 +12470,7 @@ package body Sem_Ch13 is else E := First_Entity (T); while Present (E) loop - if Comes_From_Source (E) - and then Chars (E) = Comp - then + if Comes_From_Source (E) and then Chars (E) = Comp then return E; end if; @@ -12477,7 +12481,7 @@ package body Sem_Ch13 is end if; end Visible_Component; - procedure Replace_Type_Refs is new Traverse_Proc (Replace_Type_Ref); + -- Start of processing for Replace_Type_References_Generic begin Replace_Type_Refs (N); diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 902d1fc7885..bb35ac49c20 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -26277,9 +26277,10 @@ package body Sem_Prag is ----------------------------------- function Build_Pragma_Check_Equivalent - (Prag : Node_Id; - Subp_Id : Entity_Id := Empty; - Inher_Id : Entity_Id := Empty) return Node_Id + (Prag : Node_Id; + Subp_Id : Entity_Id := Empty; + Inher_Id : Entity_Id := Empty; + Keep_Pragma_Id : Boolean := False) return Node_Id is Map : Elist_Id; -- List containing the following mappings @@ -26361,6 +26362,15 @@ package body Sem_Prag is & "for&#", N, Current_Scope); end if; + -- Update type of function call node, which should be the same as + -- the function's return type. + + if Is_Subprogram (Entity (N)) + and then Nkind (Parent (N)) = N_Function_Call + then + Set_Etype (Parent (N), Etype (Entity (N))); + end if; + -- The whole expression will be reanalyzed elsif Nkind (N) in N_Has_Etype then @@ -26595,7 +26605,6 @@ package body Sem_Prag is Set_Analyzed (Check_Prag, False); Set_Comes_From_Source (Check_Prag, False); - Set_Class_Present (Check_Prag, False); -- The tree of the original pragma may contain references to the -- formal parameters of the related subprogram. At the same time @@ -26621,15 +26630,20 @@ package body Sem_Prag is Nam := Prag_Nam; end if; - -- Convert the copy into pragma Check by correcting the name and adding - -- a check_kind argument. + -- Unless Keep_Pragma_Id is True in order to keep the identifier of + -- the copied pragma in the newly created pragma, convert the copy into + -- pragma Check by correcting the name and adding a check_kind argument. - Set_Pragma_Identifier - (Check_Prag, Make_Identifier (Loc, Name_Check)); + if not Keep_Pragma_Id then + Set_Class_Present (Check_Prag, False); - Prepend_To (Pragma_Argument_Associations (Check_Prag), - Make_Pragma_Argument_Association (Loc, - Expression => Make_Identifier (Loc, Nam))); + Set_Pragma_Identifier + (Check_Prag, Make_Identifier (Loc, Name_Check)); + + Prepend_To (Pragma_Argument_Associations (Check_Prag), + Make_Pragma_Argument_Association (Loc, + Expression => Make_Identifier (Loc, Nam))); + end if; -- Update the error message when the pragma is inherited @@ -27154,7 +27168,8 @@ package body Sem_Prag is end if; New_Prag := - Build_Pragma_Check_Equivalent (Prag, Subp, Parent_Subp); + Build_Pragma_Check_Equivalent (Prag, Subp, Parent_Subp, + Keep_Pragma_Id => True); Insert_After (Unit_Declaration_Node (Subp), New_Prag); Preanalyze (New_Prag); diff --git a/gcc/ada/sem_prag.ads b/gcc/ada/sem_prag.ads index 7afb6e662fa..d8607089a8d 100644 --- a/gcc/ada/sem_prag.ads +++ b/gcc/ada/sem_prag.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- 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- -- @@ -245,14 +245,18 @@ package Sem_Prag is -- Perform preanalysis of pragma Test_Case function Build_Pragma_Check_Equivalent - (Prag : Node_Id; - Subp_Id : Entity_Id := Empty; - Inher_Id : Entity_Id := Empty) return Node_Id; - -- Transform a [refined] pre- or postcondition denoted by Prag into an + (Prag : Node_Id; + Subp_Id : Entity_Id := Empty; + Inher_Id : Entity_Id := Empty; + Keep_Pragma_Id : Boolean := False) return Node_Id; + -- Transform a pre- or [refined] postcondition denoted by Prag into an -- equivalent pragma Check. When the pre- or postcondition is inherited, - -- the routine replaces the references of all formals of Inher_Id and - -- primitive operations of its controlling type by references to the - -- corresponding entities of Subp_Id and the descendant type. + -- the routine replaces the references of all formals of Inher_Id + -- and primitive operations of its controlling type by references + -- to the corresponding entities of Subp_Id and the descendant type. + -- Keep_Pragma_Id is True when the newly created pragma should be + -- in fact of the same kind as the source pragma Prag. This is used + -- in GNATprove_Mode to generate the inherited pre- and postconditions. procedure Check_Applicable_Policy (N : Node_Id); -- N is either an N_Aspect or an N_Pragma node. There are two cases. If diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 1dd35e4884f..d66205167b8 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12626,7 +12626,7 @@ package body Sem_Util is return True; -- An array type is effectively volatile when it is subject to pragma - -- Atomic_Components or Volatile_Components or its compolent type is + -- Atomic_Components or Volatile_Components or its component type is -- effectively volatile. elsif Is_Array_Type (Id) then diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index 4e8d51a41ae..860f0d1c978 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -7618,6 +7618,10 @@ package Sinfo is -- source, or because a Pre (resp. Post) aspect specification has been -- broken into AND THEN sections. See Split_PPC for details. + -- In GNATprove mode, the inherited classwide pre- and postconditions + -- (suitably specialized for the specific type of the overriding + -- operation) are also in this list. + -- Contract_Test_Cases contains a collection of pragmas that correspond -- to aspects/pragmas Contract_Cases and Test_Case. The ordering in the -- list is in LIFO fashion. -- 2.30.2