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

[multiple changes] 

2017-09-07  Yannick Moy  <moy@adacore.com>

	* a-exetim-mingw.ads: Add contract Global=>null
	on all operations that are modeled as having no read or write
	of global variables in SPARK.

2017-09-07  Raphael Amiard  <amiard@adacore.com>

	* a-chtgop.adb, a-chtgop.ads (Generic_Iteration_With_Position): Added
	to Hmaps.Generic_Ops.
	* a-cohama.adb (Ada.Containers.Hmaps.Iterate): Pass proper position in
	cursors.
	* a-cihama.adb (Ada.Containers.Indefinite_Hmaps.Iterate): Pass pos in
	cursors.
	* a-cohase.adb (Ada.Containers.Hashed_Sets.Iterate): Pass proper
	position in cursors.

2017-09-07  Javier Miranda  <miranda@adacore.com>

	* sem_elab.adb (Check_Task_Activation): Adding switch -gnatd.y to
	allow disabling the generation of implicit pragma Elaborate_All
	on task bodies.

2017-09-07  Javier Miranda  <miranda@adacore.com>

	* exp_disp.adb (Make_Tags): Avoid suffix counter
	in the external name of the elaboration flag. Required to fix
	the regressions introduced by the initial version of this patch.

2017-09-07  Bob Duff  <duff@adacore.com>

	* sem_ch6.adb (Analyze_Function_Return): Do not
	insert an explicit conversion to force the displacement of the
	"this" pointer to reference the secondary dispatch table in the
	case where the return statement is returning a raise expression,
	as in "return raise ...".

2017-09-07  Arnaud Charlet  <charlet@adacore.com>

	* sem_disp.adb (Is_User_Defined_Equality): Removed procedure.
	* sem_util.ads, sem_util.adb (Is_User_Defined_Equality): Copied
	procedure from sem_disp.adb.
	* sem_ch12.ads (Get_Unit_Instantiation_Node): rename Package
	with Unit.
	* sem_ch12.adb (Get_Unit_Instantiation_Node): function extended to
	return the instantiation node for subprograms. Update references
	to Get_Unit_Instantiation_Node.
	* sem_ch7.adb (Install_Parent_Private_Declarations): update
	reference to Get_Unit_Instantiation_Node.
	* exp_dist.adb (Build_Package_Stubs): update reference to
	Get_Unit_Instantiation_Node.
	* sem_ch9.adb: minor typo in comment.
	* lib-xref-spark_specific.adb
	(Traverse_Declaration_Or_Statement): traverse into task type
	definition.

2017-09-07  Ed Schonberg  <schonberg@adacore.com>

	* sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure
	to handle properly various cases of type conversions where the
	target type and/or the expression carry dimension information.
	(Dimension_System_Root); If a subtype carries dimension
	information, obtain the source parent type that carries the
	Dimension aspect.

2017-09-07  Dmitriy Anisimkov  <anisimko@adacore.com>

	* g-socket.adb, g-socket.ads (GNAT.Sockets.To_Ada): New routine.

2017-09-07  Ed Schonberg  <schonberg@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained):
	If the prefix is a reference to an object, rewrite it as an
	explicit dereference, as required by 3.7.2 (2) and as is done
	with most other attributes whose prefix is an access value.

2017-09-07  Bob Duff  <duff@adacore.com>

	* par-ch13.adb: Set the Inside_Depends flag if we are inside a
	Refined_Depends aspect.
	* par-ch2.adb: Set the Inside_Depends flag if we are inside a
	Refined_Depends pragma.
	* scans.ads: Fix documentation of Inside_Depends flag.
	* styleg.adb, styleg.ads: Minor reformatting and comment fixes.

2017-09-07  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_ch7.adb (Insert_Actions_In_Scope_Around):
	Account for the case where the are no lists to insert, but the
	secondary stack still requires management.
	* a-chtgop.adb, a-cihama.adb, a-cohama.adb, a-cohase.adb, a-tags.adb,
	comperr.adb, einfo.adb, exp_aggr.adb, exp_ch3.adb, exp_disp.adb,
	lib-xref.adb, lib-xref-spark_specific.adb, sem_ch12.adb, sem_ch13.adb,
	sem_ch6.adb, sem_dim.adb, sem_dim.ads, sem_elab.adb, sem_prag.adb:
	Minor reformatting.

From-SVN: r251842
This commit is contained in:
Arnaud Charlet 2017-09-07 12:09:17 +02:00
parent c8e072dafb
commit ed32342134
40 changed files with 418 additions and 169 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
gcc/ada/ChangeLog
View File

@ -1,3 +1,99 @@
2017-09-07 Yannick Moy <moy@adacore.com>
* a-exetim-mingw.ads: Add contract Global=>null
on all operations that are modeled as having no read or write
of global variables in SPARK.
2017-09-07 Raphael Amiard <amiard@adacore.com>
* a-chtgop.adb, a-chtgop.ads (Generic_Iteration_With_Position): Added
to Hmaps.Generic_Ops.
* a-cohama.adb (Ada.Containers.Hmaps.Iterate): Pass proper position in
cursors.
* a-cihama.adb (Ada.Containers.Indefinite_Hmaps.Iterate): Pass pos in
cursors.
* a-cohase.adb (Ada.Containers.Hashed_Sets.Iterate): Pass proper
position in cursors.
2017-09-07 Javier Miranda <miranda@adacore.com>
* sem_elab.adb (Check_Task_Activation): Adding switch -gnatd.y to
allow disabling the generation of implicit pragma Elaborate_All
on task bodies.
2017-09-07 Javier Miranda <miranda@adacore.com>
* exp_disp.adb (Make_Tags): Avoid suffix counter
in the external name of the elaboration flag. Required to fix
the regressions introduced by the initial version of this patch.
2017-09-07 Bob Duff <duff@adacore.com>
* sem_ch6.adb (Analyze_Function_Return): Do not
insert an explicit conversion to force the displacement of the
"this" pointer to reference the secondary dispatch table in the
case where the return statement is returning a raise expression,
as in "return raise ...".
2017-09-07 Arnaud Charlet <charlet@adacore.com>
* sem_disp.adb (Is_User_Defined_Equality): Removed procedure.
* sem_util.ads, sem_util.adb (Is_User_Defined_Equality): Copied
procedure from sem_disp.adb.
* sem_ch12.ads (Get_Unit_Instantiation_Node): rename Package
with Unit.
* sem_ch12.adb (Get_Unit_Instantiation_Node): function extended to
return the instantiation node for subprograms. Update references
to Get_Unit_Instantiation_Node.
* sem_ch7.adb (Install_Parent_Private_Declarations): update
reference to Get_Unit_Instantiation_Node.
* exp_dist.adb (Build_Package_Stubs): update reference to
Get_Unit_Instantiation_Node.
* sem_ch9.adb: minor typo in comment.
* lib-xref-spark_specific.adb
(Traverse_Declaration_Or_Statement): traverse into task type
definition.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* sem_dim.adb (Analyze_Dimension_Type_Conversion): New procedure
to handle properly various cases of type conversions where the
target type and/or the expression carry dimension information.
(Dimension_System_Root); If a subtype carries dimension
information, obtain the source parent type that carries the
Dimension aspect.
2017-09-07 Dmitriy Anisimkov <anisimko@adacore.com>
* g-socket.adb, g-socket.ads (GNAT.Sockets.To_Ada): New routine.
2017-09-07 Ed Schonberg <schonberg@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference, case 'Constrained):
If the prefix is a reference to an object, rewrite it as an
explicit dereference, as required by 3.7.2 (2) and as is done
with most other attributes whose prefix is an access value.
2017-09-07 Bob Duff <duff@adacore.com>
* par-ch13.adb: Set the Inside_Depends flag if we are inside a
Refined_Depends aspect.
* par-ch2.adb: Set the Inside_Depends flag if we are inside a
Refined_Depends pragma.
* scans.ads: Fix documentation of Inside_Depends flag.
* styleg.adb, styleg.ads: Minor reformatting and comment fixes.
2017-09-07 Hristian Kirtchev <kirtchev@adacore.com>
* exp_ch7.adb (Insert_Actions_In_Scope_Around):
Account for the case where the are no lists to insert, but the
secondary stack still requires management.
* a-chtgop.adb, a-cihama.adb, a-cohama.adb, a-cohase.adb, a-tags.adb,
comperr.adb, einfo.adb, exp_aggr.adb, exp_ch3.adb, exp_disp.adb,
lib-xref.adb, lib-xref-spark_specific.adb, sem_ch12.adb, sem_ch13.adb,
sem_ch6.adb, sem_dim.adb, sem_dim.ads, sem_elab.adb, sem_prag.adb:
Minor reformatting.
2017-09-07 Vincent Celier <celier@adacore.com>
* clean.adb: Do not get the target parameters before calling

31
gcc/ada/a-chtgop.adb
View File

@ -439,6 +439,33 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
-----------------------
procedure Generic_Iteration (HT : Hash_Table_Type) is
procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type);
-------------
-- Wrapper --
-------------
procedure Wrapper (Node : Node_Access; Dummy_Pos : Hash_Type) is
begin
Process (Node);
end Wrapper;
procedure Internal_With_Pos is
new Generic_Iteration_With_Position (Wrapper);
-- Start of processing for Generic_Iteration
begin
Internal_With_Pos (HT);
end Generic_Iteration;
-------------------------------------
-- Generic_Iteration_With_Position --
-------------------------------------
procedure Generic_Iteration_With_Position
(HT : Hash_Table_Type)
is
Node : Node_Access;
begin
@ -449,11 +476,11 @@ package body Ada.Containers.Hash_Tables.Generic_Operations is
for Indx in HT.Buckets'Range loop
Node := HT.Buckets (Indx);
while Node /= null loop
Process (Node);
Process (Node, Indx);
Node := Next (Node);
end loop;
end loop;
end Generic_Iteration;
end Generic_Iteration_With_Position;
------------------
-- Generic_Read --

5
gcc/ada/a-chtgop.ads
View File

@ -168,6 +168,11 @@ package Ada.Containers.Hash_Tables.Generic_Operations is
-- is not supplied, it will be recomputed. It is provided so that clients
-- can implement efficient iterators.
generic
with procedure Process (Node : Node_Access; Position : Hash_Type);
procedure Generic_Iteration_With_Position (HT : Hash_Table_Type);
-- Calls Process for each node in hash table HT
generic
with procedure Process (Node : Node_Access);
procedure Generic_Iteration (HT : Hash_Table_Type);

9
gcc/ada/a-cihama.adb
View File

@ -770,20 +770,19 @@ package body Ada.Containers.Indefinite_Hashed_Maps is
(Container : Map;
Process : not null access procedure (Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
procedure Process_Node (Node : Node_Access; Position : Hash_Type);
pragma Inline (Process_Node);
procedure Local_Iterate is
new HT_Ops.Generic_Iteration (Process_Node);
new HT_Ops.Generic_Iteration_With_Position (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
begin
Process
(Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
Process (Cursor'(Container'Unrestricted_Access, Node, Position));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);

10
gcc/ada/a-cohama.adb
View File

@ -699,19 +699,19 @@ package body Ada.Containers.Hashed_Maps is
(Container : Map;
Process : not null access procedure (Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
procedure Process_Node (Node : Node_Access; Position : Hash_Type);
pragma Inline (Process_Node);
procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
procedure Local_Iterate is
new HT_Ops.Generic_Iteration_With_Position (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
begin
Process
(Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
Process (Cursor'(Container'Unrestricted_Access, Node, Position));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);

9
gcc/ada/a-cohase.adb
View File

@ -977,20 +977,19 @@ package body Ada.Containers.Hashed_Sets is
(Container : Set;
Process : not null access procedure (Position : Cursor))
is
procedure Process_Node (Node : Node_Access);
procedure Process_Node (Node : Node_Access; Position : Hash_Type);
pragma Inline (Process_Node);
procedure Iterate is
new HT_Ops.Generic_Iteration (Process_Node);
new HT_Ops.Generic_Iteration_With_Position (Process_Node);
------------------
-- Process_Node --
------------------
procedure Process_Node (Node : Node_Access) is
procedure Process_Node (Node : Node_Access; Position : Hash_Type) is
begin
Process
(Cursor'(Container'Unrestricted_Access, Node, Hash_Type'Last));
Process (Cursor'(Container'Unrestricted_Access, Node, Position));
end Process_Node;
Busy : With_Busy (Container.HT.TC'Unrestricted_Access);

6
gcc/ada/a-exetim-mingw.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 2009-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2009-2017, Free Software Foundation, Inc. --
-- --
-- This specification is derived from the Ada Reference Manual for use with --
-- GNAT. The copyright notice above, and the license provisions that follow --
@ -79,7 +79,9 @@ is
function "-"
(Left : CPU_Time;
Right : CPU_Time) return Ada.Real_Time.Time_Span;
Right : CPU_Time) return Ada.Real_Time.Time_Span
with
Global => null;
function "<" (Left, Right : CPU_Time) return Boolean with
Global => null;

5
gcc/ada/a-tags.adb
View File

@ -915,6 +915,7 @@ package body Ada.Tags is
Prim_DT : constant Dispatch_Table_Ptr := DT (Prim_T);
Iface_Table : constant Interface_Data_Ptr :=
To_Type_Specific_Data_Ptr (Prim_DT.TSD).Interfaces_Table;
begin
-- Save Offset_Value in the table of interfaces of the primary DT.
-- This data will be used by the subprogram "Displace" to give support
@ -927,11 +928,11 @@ package body Ada.Tags is
if Iface_Table.Ifaces_Table (Id).Iface_Tag = Interface_T then
if Is_Static or else Offset_Value = 0 then
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := True;
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Value :=
Offset_Value;
else
Iface_Table.Ifaces_Table (Id).Static_Offset_To_Top := False;
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
Iface_Table.Ifaces_Table (Id).Offset_To_Top_Func :=
Offset_Func;
end if;

4
gcc/ada/comperr.adb
View File

@ -476,8 +476,8 @@ package body Comperr is
when N_Package_Body =>
Unit_Name := Corresponding_Spec (Main);
when N_Package_Renaming_Declaration
| N_Package_Instantiation
when N_Package_Instantiation
| N_Package_Renaming_Declaration
=>
Unit_Name := Defining_Unit_Name (Main);

8
gcc/ada/debug.adb
View File

@ -115,7 +115,7 @@ package body Debug is
-- d.v
-- d.w Do not check for infinite loops
-- d.x No exception handlers
-- d.y
-- d.y Disable implicit pragma Elaborate_All on task bodies
-- d.z Restore previous support for frontend handling of Inline_Always
-- d.A Read/write Aspect_Specifications hash table to tree
@ -603,6 +603,12 @@ package body Debug is
-- fully compiled and analyzed, they just get eliminated from the
-- code generation step.
-- d.y Disable implicit pragma Elaborate_All on task bodies. When a task
-- body calls a procedure in the same package, and that procedure
-- calls a procedure in another package, the static elaboration
-- machinery adds an implicit Elaborate_All on the other package. This
-- switch disables the addition of the implicit pragma in such cases.
--
-- d.z Restore previous front-end support for Inline_Always. In default
-- mode, for targets that use the GCC back end, Inline_Always is
-- handled by the back end. Use of this switch restores the previous

12
gcc/ada/einfo.adb
View File

@ -719,17 +719,17 @@ package body Einfo is
function Access_Disp_Table (Id : E) return L is
begin
pragma Assert (Ekind_In (Id, E_Record_Type,
E_Record_Type_With_Private,
E_Record_Subtype));
pragma Assert (Ekind_In (Id, E_Record_Subtype,
E_Record_Type,
E_Record_Type_With_Private));
return Elist16 (Implementation_Base_Type (Id));
end Access_Disp_Table;
function Access_Disp_Table_Elab_Flag (Id : E) return E is
begin
pragma Assert (Ekind_In (Id, E_Record_Type,
E_Record_Type_With_Private,
E_Record_Subtype));
pragma Assert (Ekind_In (Id, E_Record_Subtype,
E_Record_Type,
E_Record_Type_With_Private));
return Node30 (Implementation_Base_Type (Id));
end Access_Disp_Table_Elab_Flag;

12
gcc/ada/exp_aggr.adb
View File

@ -3322,9 +3322,9 @@ package body Exp_Aggr is
if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
Stmts_List => Assign,
(Typ => Base_Type (Typ),
Target => Target,
Stmts_List => Assign,
Init_Tags_List => Assign);
end if;
end if;
@ -3858,9 +3858,9 @@ package body Exp_Aggr is
if Has_Interfaces (Base_Type (Typ)) then
Init_Secondary_Tags
(Typ => Base_Type (Typ),
Target => Target,
Stmts_List => L,
(Typ => Base_Type (Typ),
Target => Target,
Stmts_List => L,
Init_Tags_List => L);
end if;
end if;

12
gcc/ada/exp_attr.adb
View File

@ -2671,6 +2671,18 @@ package body Exp_Attr is
New_Occurrence_Of
(Extra_Constrained (Formal_Ent), Sloc (N)));
-- If the prefix is an access to object, the attribute applies to
-- the designated object, so rewrite with an explicit dereference.
elsif Is_Access_Type (Etype (Pref))
and then
(not Is_Entity_Name (Pref) or else Is_Object (Entity (Pref)))
then
Rewrite (Pref,
Make_Explicit_Dereference (Loc, Relocate_Node (Pref)));
Analyze_And_Resolve (N, Standard_Boolean);
return;
-- For variables with a Extra_Constrained field, we use the
-- corresponding entity.

15
gcc/ada/exp_ch3.adb
View File

@ -2489,20 +2489,19 @@ package body Exp_Ch3 is
Append_To (Elab_Sec_DT_Stmts_List,
Make_Assignment_Statement (Loc,
Name =>
Name =>
New_Occurrence_Of
(Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
Expression =>
New_Occurrence_Of (Standard_False, Loc)));
Prepend_List_To (Body_Stmts,
New_List (
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List),
Prepend_List_To (Body_Stmts, New_List (
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List),
Make_If_Statement (Loc,
Condition =>
Condition =>
New_Occurrence_Of
(Access_Disp_Table_Elab_Flag (Rec_Type), Loc),
Then_Statements => Elab_Sec_DT_Stmts_List)));
@ -2510,7 +2509,7 @@ package body Exp_Ch3 is
else
Prepend_To (Body_Stmts,
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Condition => New_Occurrence_Of (Set_Tag, Loc),
Then_Statements => Init_Tags_List));
end if;

9
gcc/ada/exp_ch7.adb
View File

@ -5297,7 +5297,14 @@ package body Exp_Ch7 is
-- Start of processing for Insert_Actions_In_Scope_Around
begin
if No (Act_Before) and then No (Act_After) and then No (Act_Cleanup) then
-- Nothing to do if the scope does not manage the secondary stack or
-- does not contain meaninful actions for insertion.
if not Manage_SS
and then No (Act_Before)
and then No (Act_After)
and then No (Act_Cleanup)
then
return;
end if;

2
gcc/ada/exp_disp.adb
View File

@ -6700,7 +6700,7 @@ package body Exp_Disp is
if Elab_Flag_Needed (Typ) then
Set_Access_Disp_Table_Elab_Flag (Typ,
Make_Defining_Identifier (Loc,
New_External_Name (Tname, 'F', Suffix_Index => -1)));
Chars => New_External_Name (Tname, 'F')));
Append_To (Result,
Make_Object_Declaration (Loc,

2
gcc/ada/exp_dist.adb
View File

@ -977,7 +977,7 @@ package body Exp_Dist is
or else
(Is_Generic_Instance (Pkg_Ent)
and then Comes_From_Source
(Get_Package_Instantiation_Node (Pkg_Ent)))
(Get_Unit_Instantiation_Node (Pkg_Ent)))
then
Visit_Nested_Pkg (Decl);
end if;

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

@ -2478,6 +2478,15 @@ package body GNAT.Sockets is
return Stream_Access (S);
end Stream;
------------
-- To_Ada --
------------
function To_Ada (Fd : Integer) return Socket_Type is
begin
return Socket_Type (Fd);
end To_Ada;
----------
-- To_C --
----------

6
gcc/ada/g-socket.ads
View File

@ -456,7 +456,11 @@ package GNAT.Sockets is
function Image (Socket : Socket_Type) return String;
-- Return a printable string for Socket
function To_C (Socket : Socket_Type) return Integer;
function To_Ada (Fd : Integer) return Socket_Type with Inline;
-- Convert a file descriptor to Socket_Type. This is useful when a socket
-- file descriptor is obtained from an external library call.
function To_C (Socket : Socket_Type) return Integer with Inline;
-- Return a file descriptor to be used by external subprograms. This is
-- useful for C functions that are not yet interfaced in this package.

16
gcc/ada/lib-xref-spark_specific.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2011-2016, Free Software Foundation, Inc. --
-- Copyright (C) 2011-2017, 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- --
@ -1307,8 +1307,18 @@ package body SPARK_Specific is
when N_Protected_Type_Declaration =>
Traverse_Visible_And_Private_Parts (Protected_Definition (N));
when N_Task_Definition =>
Traverse_Visible_And_Private_Parts (N);
when N_Task_Type_Declaration =>
-- Task type definition is optional (unlike protected type
-- definition, which is mandatory).
declare
Task_Def : constant Node_Id := Task_Definition (N);
begin
if Present (Task_Def) then
Traverse_Visible_And_Private_Parts (Task_Def);
end if;
end;
when N_Task_Body =>
Traverse_Task_Body (N);

4
gcc/ada/lib-xref.adb
View File

@ -1126,12 +1126,14 @@ package body Lib.Xref is
-- Comment needed here for special SPARK code ???
if GNATprove_Mode then
-- Ignore reference to an entity that is a Part_Of single
-- Ignore references to an entity which is a Part_Of single
-- concurrent object. Ideally we would prefer to add it as a
-- reference to the corresponding concurrent type, but it is quite
-- difficult (as such references are not currently added even for)
-- reads/writes of private protected components) and not worth the
-- effort.
if Ekind_In (Ent, E_Abstract_State, E_Constant, E_Variable)
and then Present (Encapsulating_State (Ent))
and then Is_Single_Concurrent_Object (Encapsulating_State (Ent))

8
gcc/ada/par-ch13.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -520,9 +520,11 @@ package body Ch13 is
end if;
end if;
-- Note if inside Depends aspect
-- Note if inside Depends or Refined_Depends aspect
if A_Id = Aspect_Depends then
if A_Id = Aspect_Depends
or else A_Id = Aspect_Refined_Depends
then
Inside_Depends := True;
end if;

6
gcc/ada/par-ch2.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -304,7 +304,9 @@ package body Ch2 is
-- Set global to indicate if we are within a Depends pragma
if Chars (Ident_Node) = Name_Depends then
if Chars (Ident_Node) = Name_Depends
or else Chars (Ident_Node) = Name_Refined_Depends
then
Inside_Depends := True;
end if;

7
gcc/ada/scans.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -485,8 +485,9 @@ package Scans is
-- about the case of Wide_Wide_Characters???
Inside_Depends : Boolean := False;
-- True while parsing the argument of a Depends pragma or aspect (used to
-- allow/require non-standard style rules for =>+ with -gnatyt).
-- True while parsing the argument of a Depends or Refined_Depends pragma
-- or aspect. Used to allow/require nonstandard style rules for =>+ with
-- -gnatyt.
Inside_If_Expression : Nat := 0;
-- This is a counter that is set non-zero while scanning out an if

29
gcc/ada/sem_ch12.adb
View File

@ -8431,7 +8431,7 @@ package body Sem_Ch12 is
-- The parent was a premature instantiation. Insert freeze node at
-- the end the current declarative part.
if ABE_Is_Certain (Get_Package_Instantiation_Node (Par)) then
if ABE_Is_Certain (Get_Unit_Instantiation_Node (Par)) then
Insert_Freeze_Node_For_Instance (Inst_Node, F_Node);
-- Handle the following case:
@ -8452,7 +8452,7 @@ package body Sem_Ch12 is
-- after that of Parent_Inst. This relation is established by
-- comparing the Slocs of Parent_Inst freeze node and Inst.
elsif List_Containing (Get_Package_Instantiation_Node (Par)) =
elsif List_Containing (Get_Unit_Instantiation_Node (Par)) =
List_Containing (Inst_Node)
and then Sloc (Freeze_Node (Par)) < Sloc (Inst_Node)
then
@ -8574,11 +8574,11 @@ package body Sem_Ch12 is
end if;
end Get_Instance_Of;
------------------------------------
-- Get_Package_Instantiation_Node --
------------------------------------
---------------------------------
-- Get_Unit_Instantiation_Node --
---------------------------------
function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id is
function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id is
Decl : Node_Id := Unit_Declaration_Node (A);
Inst : Node_Id;
@ -8624,7 +8624,10 @@ package body Sem_Ch12 is
Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
end if;
if Nkind (Original_Node (Decl)) = N_Package_Instantiation then
if Nkind_In (Original_Node (Decl), N_Function_Instantiation,
N_Package_Instantiation,
N_Procedure_Instantiation)
then
return Original_Node (Decl);
else
return Unit (Parent (Decl));
@ -8637,15 +8640,17 @@ package body Sem_Ch12 is
else
Inst := Next (Decl);
while not Nkind_In (Inst, N_Package_Instantiation,
N_Formal_Package_Declaration)
while not Nkind_In (Inst, N_Formal_Package_Declaration,
N_Function_Instantiation,
N_Package_Instantiation,
N_Procedure_Instantiation)
loop
Next (Inst);
end loop;
return Inst;
end if;
end Get_Package_Instantiation_Node;
end Get_Unit_Instantiation_Node;
------------------------
-- Has_Been_Exchanged --
@ -9311,7 +9316,7 @@ package body Sem_Ch12 is
-- Parent_Inst. This relation is established by comparing
-- the Slocs of Parent_Inst freeze node and Inst.
if List_Containing (Get_Package_Instantiation_Node (Par)) =
if List_Containing (Get_Unit_Instantiation_Node (Par)) =
List_Containing (N)
and then Sloc (Freeze_Node (Par)) < Sloc (N)
then
@ -9572,7 +9577,7 @@ package body Sem_Ch12 is
-- Load grandparent instance as well
Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
Inst_Node := Get_Unit_Instantiation_Node (Inst_Par);
if Nkind (Name (Inst_Node)) = N_Expanded_Name then
Inst_Par := Entity (Prefix (Name (Inst_Node)));

4
gcc/ada/sem_ch12.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -93,7 +93,7 @@ package Sem_Ch12 is
-- Retrieve actual associated with given generic parameter.
-- If A is uninstantiated or not a generic parameter, return A.
function Get_Package_Instantiation_Node (A : Entity_Id) return Node_Id;
function Get_Unit_Instantiation_Node (A : Entity_Id) return Node_Id;
-- Given the entity of a unit that is an instantiation, retrieve the
-- original instance node. This is used when loading the instantiations
-- of the ancestors of a child generic that is being instantiated.

5
gcc/ada/sem_ch13.adb
View File

@ -9280,8 +9280,9 @@ package body Sem_Ch13 is
T := Standard_Integer;
when Aspect_Small =>
-- Note that the expression can be of any real type (not just
-- a real universal literal) as long as it is a static constant.
-- Note that the expression can be of any real type (not just a
-- real universal literal) as long as it is a static constant.
T := Any_Real;

2
gcc/ada/sem_ch6.adb
View File

@ -910,7 +910,7 @@ package body Sem_Ch6 is
if Expander_Active
and then Serious_Errors_Detected = 0
and then Is_Access_Type (R_Type)
and then Nkind (Expr) /= N_Null
and then not Nkind_In (Expr, N_Null, N_Raise_Expression)
and then Is_Interface (Designated_Type (R_Type))
and then Is_Progenitor (Designated_Type (R_Type),
Designated_Type (Etype (Expr)))

2
gcc/ada/sem_ch7.adb
View File

@ -1411,7 +1411,7 @@ package body Sem_Ch7 is
Gen_Par :=
Generic_Parent (Specification (Unit_Declaration_Node (Inst_Par)));
while Present (Gen_Par) and then Is_Child_Unit (Gen_Par) loop
Inst_Node := Get_Package_Instantiation_Node (Inst_Par);
Inst_Node := Get_Unit_Instantiation_Node (Inst_Par);
if Nkind_In (Inst_Node, N_Package_Instantiation,
N_Formal_Package_Declaration)

2
gcc/ada/sem_ch9.adb
View File

@ -2773,7 +2773,7 @@ package body Sem_Ch9 is
Generate_Definition (Obj_Id);
Tasking_Used := True;
-- A single task declaration is transformed into a pait of an anonymous
-- A single task declaration is transformed into a pair of an anonymous
-- task type and an object of that type. Generate:
-- task type Typ is ...;

110
gcc/ada/sem_dim.adb
View File

@ -35,6 +35,7 @@ with Nmake; use Nmake;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Eval; use Sem_Eval;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
@ -280,6 +281,14 @@ package body Sem_Dim is
-- both the identifier and the parent type of N are not dimensionless,
-- return an error.
procedure Analyze_Dimension_Type_Conversion (N : Node_Id);
-- Type conversions handle conversions between literals and dimensioned
-- types, from dimensioned types to their base type, and between different
-- dimensioned systems. Dimensions of the conversion are obtained either
-- from those of the expression, or from the target type, and dimensional
-- consistency must be checked when converting between values belonging
-- to different dimensioned systems.
procedure Analyze_Dimension_Unary_Op (N : Node_Id);
-- Subroutine of Analyze_Dimension for unary operators. For Plus, Minus and
-- Abs operators, propagate the dimensions from the operand to N.
@ -301,6 +310,11 @@ package body Sem_Dim is
-- dimension" if Description_Needed. if N is dimensionless, return "'[']",
-- or "is dimensionless" if Description_Needed.
function Dimension_System_Root (T : Entity_Id) return Entity_Id;
-- Given a type that has dimension information, return the type that is the
-- root of its dimension system, e.g. Mks_Type. If T is not a dimensioned
-- type, i.e. a standard numeric type, return Empty.
procedure Dim_Warning_For_Numeric_Literal (N : Node_Id; Typ : Entity_Id);
-- Issue a warning on the given numeric literal N to indicate that the
-- compiler made the assumption that the literal is not dimensionless
@ -1191,13 +1205,7 @@ package body Sem_Dim is
Analyze_Dimension_Subtype_Declaration (N);
when N_Type_Conversion =>
if In_Instance
and then Exists (Dimensions_Of (Expression (N)))
then
Set_Dimensions (N, Dimensions_Of (Expression (N)));
else
Analyze_Dimension_Has_Etype (N);
end if;
Analyze_Dimension_Type_Conversion (N);
when N_Unary_Op =>
Analyze_Dimension_Unary_Op (N);
@ -1384,26 +1392,6 @@ package body Sem_Dim is
return Dimensions_Of (Etype (N));
end if;
-- A type conversion may have been inserted to rewrite other
-- expressions, e.g. function returns. Dimensions are those of
-- the target type, unless this is a conversion in an instance,
-- in which case the proper dimensions are those of the operand,
elsif Nkind (N) = N_Type_Conversion then
if In_Instance
and then Is_Generic_Actual_Type (Etype (Expression (N)))
then
return Dimensions_Of (Etype (Expression (N)));
elsif In_Instance
and then Exists (Dimensions_Of (Expression (N)))
then
return Dimensions_Of (Expression (N));
else
return Dimensions_Of (Etype (N));
end if;
-- Otherwise return the default dimensions
else
@ -2339,6 +2327,56 @@ package body Sem_Dim is
end if;
end Analyze_Dimension_Subtype_Declaration;
---------------------------------------
-- Analyze_Dimension_Type_Conversion --
---------------------------------------
procedure Analyze_Dimension_Type_Conversion (N : Node_Id) is
Expr_Root : constant Entity_Id :=
Dimension_System_Root (Etype (Expression (N)));
Target_Root : constant Entity_Id :=
Dimension_System_Root (Etype (N));
begin
-- If the expression has dimensions and the target type has dimensions,
-- the conversion has the dimensions of the expression. Consistency is
-- checked below. Converting to a non-dimensioned type such as Float
-- ignores the dimensions of the expression.
if Exists (Dimensions_Of (Expression (N)))
and then Present (Target_Root)
then
Set_Dimensions (N, Dimensions_Of (Expression (N)));
-- Otherwise the dimensions are those of the target type.
else
Analyze_Dimension_Has_Etype (N);
end if;
-- A conversion between types in different dimension systems (e.g. MKS
-- and British units) must respect the dimensions of expression and
-- type, It is up to the user to provide proper conversion factors.
-- Upward conversions to root type of a dimensioned system are legal,
-- and correspond to "view conversions", i.e. preserve the dimensions
-- of the expression; otherwise conversion must be between types with
-- then same dimensions. Conversions to a non-dimensioned type such as
-- Float lose the dimensions of the expression.
if Present (Expr_Root)
and then Present (Target_Root)
and then Etype (N) /= Target_Root
and then Dimensions_Of (Expression (N)) /= Dimensions_Of (Etype (N))
then
Error_Msg_N ("dimensions mismatch in conversion", N);
Error_Msg_N
("\expression " & Dimensions_Msg_Of (Expression (N), True), N);
Error_Msg_N
("\target type " & Dimensions_Msg_Of (Etype (N), True), N);
end if;
end Analyze_Dimension_Type_Conversion;
--------------------------------
-- Analyze_Dimension_Unary_Op --
--------------------------------
@ -2665,6 +2703,24 @@ package body Sem_Dim is
or else Dimensions_Of (T1) = Dimensions_Of (T2);
end Dimensions_Match;
---------------------------
-- Dimension_System_Root --
---------------------------
function Dimension_System_Root (T : Entity_Id) return Entity_Id is
Root : Entity_Id;
begin
Root := Base_Type (T);
if Has_Dimension_System (Root) then
return First_Subtype (Root); -- for example Dim_Mks
else
return Empty;
end if;
end Dimension_System_Root;
----------------------------------------
-- Eval_Op_Expon_For_Dimensioned_Type --
----------------------------------------

16
gcc/ada/sem_dim.ads
View File

@ -195,14 +195,6 @@ package Sem_Dim is
-- a full copy of the type declaration of the parent, and the dimension
-- information of individual components must be transferred explicitly.
function New_Copy_Tree_And_Copy_Dimensions
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id;
-- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
-- also copies the dimensions of Source to the returned node.
function Dimensions_Match (T1 : Entity_Id; T2 : Entity_Id) return Boolean;
-- If the common base type has a dimension system, verify that two
-- subtypes have the same dimensions. Used for conformance checking.
@ -228,6 +220,14 @@ package Sem_Dim is
-- Return True if N is a package instantiation of System.Dim.Integer_IO or
-- of System.Dim.Float_IO.
function New_Copy_Tree_And_Copy_Dimensions
(Source : Node_Id;
Map : Elist_Id := No_Elist;
New_Sloc : Source_Ptr := No_Location;
New_Scope : Entity_Id := Empty) return Node_Id;
-- Same as New_Copy_Tree (defined in Sem_Util), except that this routine
-- also copies the dimensions of Source to the returned node.
procedure Remove_Dimension_In_Statement (Stmt : Node_Id);
-- Remove the dimensions associated with Stmt

25
gcc/ada/sem_disp.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -427,29 +427,6 @@ package body Sem_Disp is
procedure Check_Direct_Call is
Typ : Entity_Id := Etype (Control);
function Is_User_Defined_Equality (Id : Entity_Id) return Boolean;
-- Determine whether an entity denotes a user-defined equality
------------------------------
-- Is_User_Defined_Equality --
------------------------------
function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
begin
return
Ekind (Id) = E_Function
and then Chars (Id) = Name_Op_Eq
and then Comes_From_Source (Id)
-- Internally generated equalities have a full type declaration
-- as their parent.
and then Nkind (Parent (Id)) = N_Function_Specification;
end Is_User_Defined_Equality;
-- Start of processing for Check_Direct_Call
begin
-- Predefined primitives do not receive wrappers since they are built
-- from scratch for the corresponding record of synchronized types.

22
gcc/ada/sem_elab.adb
View File

@ -2961,19 +2961,21 @@ package body Sem_Elab is
Next_Elmt (Elmt);
end loop;
-- For tasks declared in the current unit, trace other calls within
-- the task procedure bodies, which are available.
-- For tasks declared in the current unit, trace other calls within the
-- task procedure bodies, which are available.
In_Task_Activation := True;
if not Debug_Flag_Dot_Y then
In_Task_Activation := True;
Elmt := First_Elmt (Intra_Procs);
while Present (Elmt) loop
Ent := Node (Elmt);
Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
Next_Elmt (Elmt);
end loop;
Elmt := First_Elmt (Intra_Procs);
while Present (Elmt) loop
Ent := Node (Elmt);
Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
Next_Elmt (Elmt);
end loop;
In_Task_Activation := False;
In_Task_Activation := False;
end if;
end Check_Task_Activation;
-------------------------------

2
gcc/ada/sem_elab.ads
View File

@ -71,7 +71,7 @@ package Sem_Elab is
-- output a warning.
-- For calls to a subprogram in a with'ed unit or a 'Access or variable
-- refernece (SPARK mode case), we require that a pragma Elaborate_All
-- reference (SPARK mode case), we require that a pragma Elaborate_All
-- or pragma Elaborate be present, or that the referenced unit have a
-- pragma Preelaborate, pragma Pure, or pragma Elaborate_Body. If none
-- of these conditions is met, then a warning is generated that a pragma

6
gcc/ada/sem_prag.adb
View File

@ -3076,9 +3076,11 @@ package body Sem_Prag is
and then Nkind (Decl) = N_Object_Declaration
then
Append_New_Elmt (Defining_Entity (Decl), States_And_Objs);
elsif Is_Single_Concurrent_Type_Declaration (Decl) then
Append_New_Elmt (Anonymous_Object (Defining_Entity (Decl)),
States_And_Objs);
Append_New_Elmt
(Anonymous_Object (Defining_Entity (Decl)),
States_And_Objs);
end if;
Next (Decl);

16
gcc/ada/sem_util.adb
View File

@ -15730,6 +15730,22 @@ package body Sem_Util is
return T = Universal_Integer or else T = Universal_Real;
end Is_Universal_Numeric_Type;
------------------------------
-- Is_User_Defined_Equality --
------------------------------
function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
begin
return Ekind (Id) = E_Function
and then Chars (Id) = Name_Op_Eq
and then Comes_From_Source (Id)
-- Internally generated equalities have a full type declaration
-- as their parent.
and then Nkind (Parent (Id)) = N_Function_Specification;
end Is_User_Defined_Equality;
--------------------------------------
-- Is_Validation_Variable_Reference --
--------------------------------------

3
gcc/ada/sem_util.ads
View File

@ -1875,6 +1875,9 @@ package Sem_Util is
pragma Inline (Is_Universal_Numeric_Type);
-- True if T is Universal_Integer or Universal_Real
function Is_User_Defined_Equality (Id : Entity_Id) return Boolean;
-- Determine whether an entity denotes a user-defined equality
function Is_Validation_Variable_Reference (N : Node_Id) return Boolean;
-- Determine whether N denotes a reference to a variable which captures the
-- value of an object for validation purposes.

29
gcc/ada/styleg.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -127,20 +127,17 @@ package body Styleg is
-----------------
-- In check tokens mode (-gnatys), arrow must be surrounded by spaces,
-- except that within the argument of a Depends macro the required format
-- is =>+ rather than => +).
-- except that within the argument of a Depends or Refined_Depends aspect
-- or pragma the required format is "=>+ " rather than "=> +").
procedure Check_Arrow (Inside_Depends : Boolean := False) is
begin
if Style_Check_Tokens then
Require_Preceding_Space;
if not Inside_Depends then
Require_Following_Space;
-- Special handling for Depends and Refined_Depends
-- Special handling for Inside_Depends
else
if Inside_Depends then
if Source (Scan_Ptr) = ' '
and then Source (Scan_Ptr + 1) = '+'
then
@ -151,6 +148,11 @@ package body Styleg is
then
Require_Following_Space;
end if;
-- Normal case
else
Require_Following_Space;
end if;
end if;
end Check_Arrow;
@ -1054,16 +1056,17 @@ package body Styleg is
-- In check token mode (-gnatyt), unary plus or minus must not be
-- followed by a space.
-- Annoying exception: if we have the sequence =>+ within a Depends pragma
-- or aspect, then we insist on a space rather than forbidding it.
-- Annoying exception: if we have the sequence =>+ within a Depends or
-- Refined_Depends pragma or aspect, then we insist on a space rather
-- than forbidding it.
procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False) is
begin
if Style_Check_Tokens then
if not Inside_Depends then
Check_No_Space_After;
else
if Inside_Depends then
Require_Following_Space;
else
Check_No_Space_After;
end if;
end if;
end Check_Unary_Plus_Or_Minus;

11
gcc/ada/styleg.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2015, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2017, 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- --
@ -54,8 +54,8 @@ package Styleg is
procedure Check_Arrow (Inside_Depends : Boolean := False);
-- Called after scanning out an arrow to check spacing. Inside_Depends is
-- true if the call is from an argument of the Depends pragma (where the
-- allowed/required format is =>+).
-- True if the call is from an argument of the Depends or Refined_Depends
-- aspect or pragma (where the allowed/required format is =>+).
procedure Check_Attribute_Name (Reserved : Boolean);
-- The current token is an attribute designator. Check that it
@ -147,8 +147,9 @@ package Styleg is
procedure Check_Unary_Plus_Or_Minus (Inside_Depends : Boolean := False);
-- Called after scanning a unary plus or minus to check spacing. The flag
-- Inside_Depends is set if we are scanning within a Depends pragma or
-- Aspect, in which case =>+ requires a following space).
-- Inside_Depends is set if we are scanning within a Depends or
-- Refined_Depends pragma or Aspect, in which case =>+ requires a
-- following space.
procedure Check_Vertical_Bar;
-- Called after scanning a vertical bar to check spacing