OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

2016-06-20  Hristian Kirtchev  <kirtchev@adacore.com>

	* 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  <moy@adacore.com>

	* 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  <kirtchev@adacore.com>

	* 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
This commit is contained in:
Arnaud Charlet 2016-06-20 14:31:47 +02:00
parent 9e3be36e46
commit 20250fb87c
11 changed files with 190 additions and 89 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
gcc/ada/ChangeLog
View File

@ -1,3 +1,32 @@
2016-06-20 Hristian Kirtchev <kirtchev@adacore.com>
* 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 <moy@adacore.com>
* 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 <kirtchev@adacore.com>
* 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 <schonberg@adacore.com>
* sem_ch13.adb (Visible_Component): New procedure, subsidiary

102
gcc/ada/exp_ch7.adb
View File

@ -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 <Work_Typ>[Partial_]Invariant (_object : <Work_Typ>) is
-- begin
-- <Stmts>
-- end <Work_Typ>[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;
Set_Ekind (Proc_Id, E_Procedure);
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_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 <Work_Typ>[Partial_]Invariant (_object : <Work_Typ>);
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;

17
gcc/ada/g-socket.adb
View File

@ -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;
-- Definitely not a proper dotted quad
else
-- Definitely not a proper dotted quad
return False;
end if;

3
gcc/ada/gnatbind.adb
View File

@ -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;

4
gcc/ada/lib.ads
View File

@ -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

3
gcc/ada/make.adb
View File

@ -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;

56
gcc/ada/sem_ch13.adb
View File

@ -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);

39
gcc/ada/sem_prag.adb
View File

@ -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);

20
gcc/ada/sem_prag.ads
View File

@ -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

2
gcc/ada/sem_util.adb
View File

@ -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

4
gcc/ada/sinfo.ads
View File

@ -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.