git
/
gcc
mirror of git://gcc.gnu.org/git/gcc.git
1
0
Fork 0
Code Issues Packages Projects Releases Wiki Activity

[multiple changes] 

2017-01-06  Tristan Gingold  <gingold@adacore.com>

	* ada.ads, a-unccon.ads: Add pragma No_Elaboration_Code_All.

2017-01-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* sem_case.adb: Minor reformatting.

2017-01-06  Thomas Quinot  <quinot@adacore.com>

	* g-socthi-mingw.adb: Remove now extraneous USE TYPE clause

2017-01-06  Justin Squirek  <squirek@adacore.com>

	* aspects.adb: Register aspect in Canonical_Aspect.
	* aspects.ads: Associate qualities of Aspect_Max_Queue_Length
	into respective tables.
	* einfo.ads, einfo.adb: Add a new attribute for
	handling the parameters for Pragma_Max_Entry_Queue
	(Entry_Max_Queue_Lengths_Array) in E_Protected_Type. Subprograms
	for accessing and setting were added as well.
	* par-prag.adb (Prag): Register Pramga_Max_Entry_Queue.
	* exp_ch9.adb (Expand_N_Protected_Type_Declaration): Emit
	declaration for pramga arguments and store them in the protected
	type node.
	(Make_Initialize_Protection): Pass a reference to
	the Entry_Max_Queue_Lengths_Array in the protected type node to
	the runtime.
	* rtsfind.adb: Minor grammar fix.
	* rtsfind.ads: Register new types taken from the
	runtime libraries RE_Protected_Entry_Queue_Max and
	RE_Protected_Entry_Queue_Max_Array
	* s-tposen.adb, s-tpoben.adb
	(Initialize_Protection_Entry/Initialize_Protection_Entries):
	Add extra parameter and add assignment to local object.
	* s-tposen.ads, s-tpoben.ads: Add new types to
	store entry queue maximums and a field to the entry object record.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Add case statement
	for Aspect_Max_Queue_Length.
	(Check_Aspect_At_Freeze_Point):
	Add aspect to list of aspects that don't require delayed analysis.
	* sem_prag.adb (Analyze_Pragma): Add case statement for
	Pragma_Max_Queue_Length, check semantics, and register arugments
	in the respective entry nodes.
	* sem_util.adb, sem_util.ads Add functions Get_Max_Queue_Length
	and Has_Max_Queue_Length
	* snames.ads-tmpl: Add constant for the new aspect-name
	Name_Max_Queue_Length and corrasponding pragma.

2017-01-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_util.adb (Is_Controlled_Function_Call):
	Reimplemented. Consider any node which has an entity as the
	function call may appear in various ways.

From-SVN: r244126
This commit is contained in:
Arnaud Charlet 2017-01-06 11:33:48 +01:00
parent ed3fe8cc27
commit 442d1abbc4
23 changed files with 428 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
gcc/ada/ChangeLog
View File

@ -1,3 +1,58 @@
2017-01-06 Tristan Gingold <gingold@adacore.com>
* ada.ads, a-unccon.ads: Add pragma No_Elaboration_Code_All.
2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
* sem_case.adb: Minor reformatting.
2017-01-06 Thomas Quinot <quinot@adacore.com>
* g-socthi-mingw.adb: Remove now extraneous USE TYPE clause
2017-01-06 Justin Squirek <squirek@adacore.com>
* aspects.adb: Register aspect in Canonical_Aspect.
* aspects.ads: Associate qualities of Aspect_Max_Queue_Length
into respective tables.
* einfo.ads, einfo.adb: Add a new attribute for
handling the parameters for Pragma_Max_Entry_Queue
(Entry_Max_Queue_Lengths_Array) in E_Protected_Type. Subprograms
for accessing and setting were added as well.
* par-prag.adb (Prag): Register Pramga_Max_Entry_Queue.
* exp_ch9.adb (Expand_N_Protected_Type_Declaration): Emit
declaration for pramga arguments and store them in the protected
type node.
(Make_Initialize_Protection): Pass a reference to
the Entry_Max_Queue_Lengths_Array in the protected type node to
the runtime.
* rtsfind.adb: Minor grammar fix.
* rtsfind.ads: Register new types taken from the
runtime libraries RE_Protected_Entry_Queue_Max and
RE_Protected_Entry_Queue_Max_Array
* s-tposen.adb, s-tpoben.adb
(Initialize_Protection_Entry/Initialize_Protection_Entries):
Add extra parameter and add assignment to local object.
* s-tposen.ads, s-tpoben.ads: Add new types to
store entry queue maximums and a field to the entry object record.
* sem_ch13.adb (Analyze_Aspect_Specifications): Add case statement
for Aspect_Max_Queue_Length.
(Check_Aspect_At_Freeze_Point):
Add aspect to list of aspects that don't require delayed analysis.
* sem_prag.adb (Analyze_Pragma): Add case statement for
Pragma_Max_Queue_Length, check semantics, and register arugments
in the respective entry nodes.
* sem_util.adb, sem_util.ads Add functions Get_Max_Queue_Length
and Has_Max_Queue_Length
* snames.ads-tmpl: Add constant for the new aspect-name
Name_Max_Queue_Length and corrasponding pragma.
2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_util.adb (Is_Controlled_Function_Call):
Reimplemented. Consider any node which has an entity as the
function call may appear in various ways.
2017-01-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_attr.adb (Rewrite_Stream_Proc_Call): Use

1
gcc/ada/a-unccon.ads
View File

@ -19,5 +19,6 @@ generic
function Ada.Unchecked_Conversion (S : Source) return Target;
pragma No_Elaboration_Code_All (Unchecked_Conversion);
pragma Pure (Unchecked_Conversion);
pragma Import (Intrinsic, Unchecked_Conversion);

1
gcc/ada/ada.ads
View File

@ -14,6 +14,7 @@
------------------------------------------------------------------------------
package Ada is
pragma No_Elaboration_Code_All;
pragma Pure;
end Ada;

3
gcc/ada/aspects.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2010-2015, Free Software Foundation, Inc. --
-- Copyright (C) 2010-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- --
@ -568,6 +568,7 @@ package body Aspects is
Aspect_Linker_Section => Aspect_Linker_Section,
Aspect_Lock_Free => Aspect_Lock_Free,
Aspect_Machine_Radix => Aspect_Machine_Radix,
Aspect_Max_Queue_Length => Aspect_Max_Queue_Length,
Aspect_No_Elaboration_Code_All => Aspect_No_Elaboration_Code_All,
Aspect_No_Return => Aspect_No_Return,
Aspect_No_Tagged_Streams => Aspect_No_Tagged_Streams,

5
gcc/ada/aspects.ads
View File

@ -116,6 +116,7 @@ package Aspects is
Aspect_Link_Name,
Aspect_Linker_Section, -- GNAT
Aspect_Machine_Radix,
Aspect_Max_Queue_Length, -- GNAT
Aspect_Object_Size, -- GNAT
Aspect_Obsolescent, -- GNAT
Aspect_Output,
@ -247,6 +248,7 @@ package Aspects is
Aspect_Inline_Always => True,
Aspect_Invariant => True,
Aspect_Lock_Free => True,
Aspect_Max_Queue_Length => True,
Aspect_Object_Size => True,
Aspect_Persistent_BSS => True,
Aspect_Predicate => True,
@ -353,6 +355,7 @@ package Aspects is
Aspect_Link_Name => Expression,
Aspect_Linker_Section => Expression,
Aspect_Machine_Radix => Expression,
Aspect_Max_Queue_Length => Expression,
Aspect_Object_Size => Expression,
Aspect_Obsolescent => Optional_Expression,
Aspect_Output => Name,
@ -460,6 +463,7 @@ package Aspects is
Aspect_Linker_Section => Name_Linker_Section,
Aspect_Lock_Free => Name_Lock_Free,
Aspect_Machine_Radix => Name_Machine_Radix,
Aspect_Max_Queue_Length => Name_Max_Queue_Length,
Aspect_No_Elaboration_Code_All => Name_No_Elaboration_Code_All,
Aspect_No_Return => Name_No_Return,
Aspect_No_Tagged_Streams => Name_No_Tagged_Streams,
@ -731,6 +735,7 @@ package Aspects is
Aspect_Import => Never_Delay,
Aspect_Initial_Condition => Never_Delay,
Aspect_Initializes => Never_Delay,
Aspect_Max_Queue_Length => Never_Delay,
Aspect_No_Elaboration_Code_All => Never_Delay,
Aspect_No_Tagged_Streams => Never_Delay,
Aspect_Obsolescent => Never_Delay,

17
gcc/ada/einfo.adb
View File

@ -267,6 +267,7 @@ package body Einfo is
-- Contract Node34
-- Anonymous_Designated_Type Node35
-- Entry_Max_Queue_Lengths_Array Node35
-- Import_Pragma Node35
-- Class_Wide_Preconds List38
@ -1221,6 +1222,12 @@ package body Einfo is
return Node18 (Id);
end Entry_Index_Constant;
function Entry_Max_Queue_Lengths_Array (Id : E) return N is
begin
pragma Assert (Ekind (Id) = E_Protected_Type);
return Node35 (Id);
end Entry_Max_Queue_Lengths_Array;
function Contains_Ignored_Ghost_Code (Id : E) return B is
begin
pragma Assert
@ -4286,6 +4293,12 @@ package body Einfo is
Set_Node18 (Id, V);
end Set_Entry_Index_Constant;
procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E) is
begin
pragma Assert (Ekind (Id) = E_Protected_Type);
Set_Node35 (Id, V);
end Set_Entry_Max_Queue_Lengths_Array;
procedure Set_Entry_Parameters_Type (Id : E; V : E) is
begin
Set_Node15 (Id, V);
@ -10738,6 +10751,10 @@ package body Einfo is
when E_Variable =>
Write_Str ("Anonymous_Designated_Type");
when E_Entry |
E_Entry_Family =>
Write_Str ("Entry_Max_Queue_Lenghts_Array");
when Subprogram_Kind =>
Write_Str ("Import_Pragma");

9
gcc/ada/einfo.ads
View File

@ -1154,6 +1154,11 @@ package Einfo is
-- accept statement for a member of the family, and in the prefix of
-- 'COUNT when it applies to a family member.
-- Entry_Max_Queue_Lengths_Array (Node35)
-- Defined in protected types for which Has_Entries is true. Contains the
-- defining identifier for the array of naturals used by the runtime to
-- limit the queue size of each entry individually.
-- Entry_Parameters_Type (Node15)
-- Defined in entries. Points to the access-to-record type that is
-- constructed by the expander to hold a reference to the parameter
@ -6381,6 +6386,7 @@ package Einfo is
-- Stored_Constraint (Elist23)
-- Anonymous_Object (Node30)
-- Contract (Node34)
-- Entry_Max_Queue_Lengths_Array (Node35)
-- SPARK_Pragma (Node40)
-- SPARK_Aux_Pragma (Node41)
-- Sec_Stack_Needed_For_Return (Flag167) ???
@ -6928,6 +6934,7 @@ package Einfo is
function Entry_Formal (Id : E) return E;
function Entry_Index_Constant (Id : E) return E;
function Entry_Index_Type (Id : E) return E;
function Entry_Max_Queue_Lengths_Array (Id : E) return E;
function Entry_Parameters_Type (Id : E) return E;
function Enum_Pos_To_Rep (Id : E) return E;
function Enumeration_Pos (Id : E) return U;
@ -7608,6 +7615,7 @@ package Einfo is
procedure Set_Entry_Component (Id : E; V : E);
procedure Set_Entry_Formal (Id : E; V : E);
procedure Set_Entry_Index_Constant (Id : E; V : E);
procedure Set_Entry_Max_Queue_Lengths_Array (Id : E; V : E);
procedure Set_Entry_Parameters_Type (Id : E; V : E);
procedure Set_Enum_Pos_To_Rep (Id : E; V : E);
procedure Set_Enumeration_Pos (Id : E; V : U);
@ -8921,6 +8929,7 @@ package Einfo is
pragma Inline (Set_Entry_Cancel_Parameter);
pragma Inline (Set_Entry_Component);
pragma Inline (Set_Entry_Formal);
pragma Inline (Set_Entry_Max_Queue_Lengths_Array);
pragma Inline (Set_Entry_Parameters_Type);
pragma Inline (Set_Enum_Pos_To_Rep);
pragma Inline (Set_Enumeration_Pos);

179
gcc/ada/exp_ch9.adb
View File

@ -9045,7 +9045,7 @@ package body Exp_Ch9 is
-- the specs refer to this type.
procedure Expand_N_Protected_Type_Declaration (N : Node_Id) is
Discr_Map : constant Elist_Id := New_Elmt_List;
Discr_Map : constant Elist_Id := New_Elmt_List;
Loc : constant Source_Ptr := Sloc (N);
Prot_Typ : constant Entity_Id := Defining_Identifier (N);
@ -9055,17 +9055,9 @@ package body Exp_Ch9 is
Pdef : constant Node_Id := Protected_Definition (N);
-- This contains two lists; one for visible and one for private decls
Body_Arr : Node_Id;
Body_Id : Entity_Id;
Cdecls : List_Id;
Comp : Node_Id;
Current_Node : Node_Id := N;
E_Count : Int;
Entries_Aggr : Node_Id;
New_Priv : Node_Id;
Object_Comp : Node_Id;
Priv : Node_Id;
Rec_Decl : Node_Id;
procedure Check_Inlining (Subp : Entity_Id);
-- If the original operation has a pragma Inline, propagate the flag
@ -9295,7 +9287,17 @@ package body Exp_Ch9 is
-- Local variables
Sub : Node_Id;
Body_Arr : Node_Id;
Body_Id : Entity_Id;
Cdecls : List_Id;
Comp : Node_Id;
Expr : Node_Id;
New_Priv : Node_Id;
Obj_Def : Node_Id;
Object_Comp : Node_Id;
Priv : Node_Id;
Rec_Decl : Node_Id;
Sub : Node_Id;
-- Start of processing for Expand_N_Protected_Type_Declaration
@ -9760,6 +9762,96 @@ package body Exp_Ch9 is
end loop;
end if;
-- Create the declaration of an array object which contains the values
-- of aspect/pragma Max_Queue_Length for all entries of the protected
-- type. This object is later passed to the appropriate protected object
-- initialization routine.
declare
Maxs : constant List_Id := New_List;
Count : Int;
Item : Entity_Id;
Maxs_Id : Entity_Id;
Max_Vals : Node_Id;
begin
if Has_Entries (Prot_Typ) then
-- Gather the Max_Queue_Length values of all entries in a list. A
-- value of zero indicates that the entry has no limitation on its
-- queue length.
Count := 0;
Item := First_Entity (Prot_Typ);
while Present (Item) loop
if Is_Entry (Item) then
Count := Count + 1;
Append_To (Maxs,
Make_Integer_Literal (Loc,
Intval => Get_Max_Queue_Length (Item)));
end if;
Next_Entity (Item);
end loop;
-- Create the declaration of the array object. Generate:
-- Maxs_Id : aliased Protected_Entry_Queue_Max_Array
-- (1 .. Count) := (..., ...);
-- or
-- Maxs_Id : aliased Protected_Entry_Queue_Max := <value>;
Maxs_Id :=
Make_Defining_Identifier (Loc,
Chars => New_External_Name (Chars (Prot_Typ), 'B'));
case Corresponding_Runtime_Package (Prot_Typ) is
when System_Tasking_Protected_Objects_Entries =>
Expr := Make_Aggregate (Loc, Maxs);
Obj_Def :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(RTE (RE_Protected_Entry_Queue_Max_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Make_Integer_Literal (Loc, 1),
Make_Integer_Literal (Loc, Count)))));
when System_Tasking_Protected_Objects_Single_Entry =>
Expr := Make_Integer_Literal (Loc, Intval (First (Maxs)));
Obj_Def :=
New_Occurrence_Of
(RTE (RE_Protected_Entry_Queue_Max), Loc);
when others =>
raise Program_Error;
end case;
Max_Vals :=
Make_Object_Declaration (Loc,
Defining_Identifier => Maxs_Id,
Aliased_Present => True,
Object_Definition => Obj_Def,
Expression => Expr);
-- A pointer to this array will be placed in the corresponding
-- record by its initialization procedure so this needs to be
-- analyzed here.
Insert_After (Current_Node, Max_Vals);
Current_Node := Max_Vals;
Analyze (Max_Vals);
Set_Entry_Max_Queue_Lengths_Array (Prot_Typ, Maxs_Id);
end if;
end;
-- Emit declaration for Entry_Bodies_Array, now that the addresses of
-- all protected subprograms have been collected.
@ -9770,37 +9862,34 @@ package body Exp_Ch9 is
case Corresponding_Runtime_Package (Prot_Typ) is
when System_Tasking_Protected_Objects_Entries =>
Body_Arr :=
Make_Object_Declaration (Loc,
Defining_Identifier => Body_Id,
Aliased_Present => True,
Object_Definition =>
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(RTE (RE_Protected_Entry_Body_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Make_Integer_Literal (Loc, 1),
Make_Integer_Literal (Loc, E_Count))))),
Expression => Entries_Aggr);
Expr := Entries_Aggr;
Obj_Def :=
Make_Subtype_Indication (Loc,
Subtype_Mark =>
New_Occurrence_Of
(RTE (RE_Protected_Entry_Body_Array), Loc),
Constraint =>
Make_Index_Or_Discriminant_Constraint (Loc,
Constraints => New_List (
Make_Range (Loc,
Make_Integer_Literal (Loc, 1),
Make_Integer_Literal (Loc, E_Count)))));
when System_Tasking_Protected_Objects_Single_Entry =>
Body_Arr :=
Make_Object_Declaration (Loc,
Defining_Identifier => Body_Id,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (RTE (RE_Entry_Body), Loc),
Expression =>
Remove_Head (Expressions (Entries_Aggr)));
Expr := Remove_Head (Expressions (Entries_Aggr));
Obj_Def := New_Occurrence_Of (RTE (RE_Entry_Body), Loc);
when others =>
raise Program_Error;
end case;
Body_Arr :=
Make_Object_Declaration (Loc,
Defining_Identifier => Body_Id,
Aliased_Present => True,
Object_Definition => Obj_Def,
Expression => Expr);
-- A pointer to this array will be placed in the corresponding record
-- by its initialization procedure so this needs to be analyzed here.
@ -9821,6 +9910,7 @@ package body Exp_Ch9 is
Sub :=
Make_Subprogram_Declaration (Loc,
Specification => Build_Find_Body_Index_Spec (Prot_Typ));
Insert_After (Current_Node, Sub);
Analyze (Sub);
end if;
@ -14107,6 +14197,27 @@ package body Exp_Ch9 is
raise Program_Error;
end case;
-- Entry_Queue_Maxs parameter. This is a pointer to an array of
-- naturals representing the entry queue maximums for each entry
-- in the protected type. Zero represents no max.
if Has_Entry then
Append_To (Args,
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of
(Entry_Max_Queue_Lengths_Array (Ptyp), Loc),
Attribute_Name => Name_Unrestricted_Access));
-- Edge cases exist where entry initialization functions are
-- called, but no entries exist, so null is appended.
elsif Pkg_Id = System_Tasking_Protected_Objects_Single_Entry
or else Pkg_Id = System_Tasking_Protected_Objects_Entries
then
Append_To (Args, Make_Null (Loc));
end if;
-- Entry_Bodies parameter. This is a pointer to an array of
-- pointers to the entry body procedures and barrier functions of
-- the object. If the protected type has no entries this object

29
gcc/ada/exp_util.adb
View File

@ -4912,35 +4912,28 @@ package body Exp_Util is
-- Obj.Func (Formal => Actual) N_Function_Call, whose Name is an
-- N_Selected_Component
case Nkind (Expr) is
when N_Function_Call =>
loop
if Nkind (Expr) = N_Function_Call then
Expr := Name (Expr);
-- Check for "Obj.Func (Formal => Actual)" case
if Nkind (Expr) = N_Selected_Component then
Expr := Selector_Name (Expr);
end if;
-- "Obj.Func (Actual)" case
when N_Indexed_Component =>
elsif Nkind (Expr) = N_Indexed_Component then
Expr := Prefix (Expr);
if Nkind (Expr) = N_Selected_Component then
Expr := Selector_Name (Expr);
end if;
-- "Obj.Func" or "Obj.Func (Formal => Actual) case
-- "Obj.Func" case
when N_Selected_Component =>
elsif Nkind (Expr) = N_Selected_Component then
Expr := Selector_Name (Expr);
when others => null;
end case;
else
exit;
end if;
end loop;
return
Nkind_In (Expr, N_Expanded_Name, N_Identifier)
Nkind (Expr) in N_Has_Entity
and then Present (Entity (Expr))
and then Ekind (Entity (Expr)) = E_Function
and then Needs_Finalization (Etype (Entity (Expr)));
end Is_Controlled_Function_Call;

3
gcc/ada/g-socthi-mingw.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2001-2014, AdaCore --
-- Copyright (C) 2001-2016, AdaCore --
-- --
-- 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- --
@ -43,7 +43,6 @@ with System.Storage_Elements; use System.Storage_Elements;
package body GNAT.Sockets.Thin is
use type C.unsigned;
use type C.int;
WSAData_Dummy : array (1 .. 512) of C.int;

1
gcc/ada/par-prag.adb
View File

@ -1396,6 +1396,7 @@ begin
Pragma_Machine_Attribute |
Pragma_Main |
Pragma_Main_Storage |
Pragma_Max_Queue_Length |
Pragma_Memory_Size |
Pragma_No_Body |
Pragma_No_Elaboration_Code_All |

2
gcc/ada/rtsfind.adb
View File

@ -1351,7 +1351,7 @@ package body Rtsfind is
-- is System. If so, return the value from the already compiled
-- declaration and otherwise do a regular find.
-- Not pleasant, but these kinds of annoying recursion when
-- Not pleasant, but these kinds of annoying recursion senarios when
-- writing an Ada compiler in Ada have to be broken somewhere.
if Present (Main_Unit_Entity)

6
gcc/ada/rtsfind.ads
View File

@ -1684,6 +1684,7 @@ package Rtsfind is
RE_Protected_Entry_Body_Array, -- Tasking.Protected_Objects.Entries
RE_Protected_Entry_Names_Array, -- Tasking.Protected_Objects.Entries
RE_Protected_Entry_Queue_Max_Array, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries, -- Tasking.Protected_Objects.Entries
RE_Protection_Entries_Access, -- Tasking.Protected_Objects.Entries
RE_Initialize_Protection_Entries, -- Tasking.Protected_Objects.Entries
@ -1716,6 +1717,7 @@ package Rtsfind is
RE_Service_Entry, -- Protected_Objects.Single_Entry
RE_Exceptional_Complete_Single_Entry_Body,
RE_Protected_Count_Entry, -- Protected_Objects.Single_Entry
RE_Protected_Entry_Queue_Max, -- Protected_Objects.Single_Entry
RE_Protected_Single_Entry_Caller, -- Protected_Objects.Single_Entry
RE_Protected_Entry_Index, -- System.Tasking.Protected_Objects
@ -2927,6 +2929,8 @@ package Rtsfind is
System_Tasking_Protected_Objects_Entries,
RE_Protected_Entry_Names_Array =>
System_Tasking_Protected_Objects_Entries,
RE_Protected_Entry_Queue_Max_Array =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries =>
System_Tasking_Protected_Objects_Entries,
RE_Protection_Entries_Access =>
@ -2989,6 +2993,8 @@ package Rtsfind is
System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Count_Entry =>
System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Entry_Queue_Max =>
System_Tasking_Protected_Objects_Single_Entry,
RE_Protected_Single_Entry_Caller =>
System_Tasking_Protected_Objects_Single_Entry,

4
gcc/ada/s-tpoben.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2014, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -174,6 +174,7 @@ package body System.Tasking.Protected_Objects.Entries is
(Object : Protection_Entries_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access;
Entry_Bodies : Protected_Entry_Body_Access;
Find_Body_Index : Find_Body_Index_Access)
is
@ -211,6 +212,7 @@ package body System.Tasking.Protected_Objects.Entries is
Object.Compiler_Info := Compiler_Info;
Object.Pending_Action := False;
Object.Call_In_Progress := null;
Object.Entry_Queue_Maxs := Entry_Queue_Maxs;
Object.Entry_Bodies := Entry_Bodies;
Object.Find_Body_Index := Find_Body_Index;

13
gcc/ada/s-tpoben.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2012, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -66,6 +66,12 @@ package System.Tasking.Protected_Objects.Entries is
type Protected_Entry_Queue_Array is
array (Protected_Entry_Index range <>) of Entry_Queue;
type Protected_Entry_Queue_Max_Array is
array (Positive_Protected_Entry_Index range <>) of Natural;
type Protected_Entry_Queue_Max_Access is
access all Protected_Entry_Queue_Max_Array;
-- The following declarations define an array that contains the string
-- names of entries and entry family members, together with an associated
-- access type.
@ -144,6 +150,10 @@ package System.Tasking.Protected_Objects.Entries is
Entry_Queues : Protected_Entry_Queue_Array (1 .. Num_Entries);
Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access;
-- Access to an array of naturals representing the max value for
-- each entry's queue length. A value of 0 signifies no max.
Entry_Names : Protected_Entry_Names_Access := null;
-- An array of string names which denotes entry [family member] names.
-- The structure is indexed by protected entry index and contains Num_
@ -178,6 +188,7 @@ package System.Tasking.Protected_Objects.Entries is
(Object : Protection_Entries_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
Entry_Queue_Maxs : Protected_Entry_Queue_Max_Access;
Entry_Bodies : Protected_Entry_Body_Access;
Find_Body_Index : Find_Body_Index_Access);
-- Initialize the Object parameter so that it can be used by the runtime

4
gcc/ada/s-tposen.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1998-2013, Free Software Foundation, Inc. --
-- Copyright (C) 1998-2016, Free Software Foundation, Inc. --
-- --
-- GNARL 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- --
@ -218,6 +218,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
(Object : Protection_Entry_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
Entry_Queue_Max : Protected_Entry_Queue_Max_Access;
Entry_Body : Entry_Body_Access)
is
begin
@ -226,6 +227,7 @@ package body System.Tasking.Protected_Objects.Single_Entry is
Object.Compiler_Info := Compiler_Info;
Object.Call_In_Progress := null;
Object.Entry_Body := Entry_Body;
Object.Entry_Queue_Max := Entry_Queue_Max;
Object.Entry_Queue := null;
end Initialize_Protection_Entry;

12
gcc/ada/s-tposen.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2013, 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- --
@ -182,10 +182,16 @@ package System.Tasking.Protected_Objects.Single_Entry is
type Protection_Entry_Access is access all Protection_Entry;
type Protected_Entry_Queue_Max is new Natural;
type Protected_Entry_Queue_Max_Access is
access all Protected_Entry_Queue_Max;
procedure Initialize_Protection_Entry
(Object : Protection_Entry_Access;
Ceiling_Priority : Integer;
Compiler_Info : System.Address;
Entry_Queue_Max : Protected_Entry_Queue_Max_Access;
Entry_Body : Entry_Body_Access);
-- Initialize the Object parameter so that it can be used by the run time
-- to keep track of the runtime state of a protected object.
@ -270,6 +276,10 @@ private
Entry_Queue : Entry_Call_Link;
-- Place to store the waiting entry call (if any)
Entry_Queue_Max : Protected_Entry_Queue_Max_Access;
-- Access to a natural representing the max value for the single
-- entry's queue length. A value of 0 signifies no max.
end record;
end System.Tasking.Protected_Objects.Single_Entry;

17
gcc/ada/sem_case.adb
View File

@ -1369,9 +1369,9 @@ package body Sem_Case is
Lo : Node_Id;
Hi : Node_Id);
-- If the type of the alternative has predicates, we must examine
-- each subset of the predicate rather than the bounds of the
-- type itself. This is relevant when the choice is a subtype mark
-- or a subtype indication.
-- each subset of the predicate rather than the bounds of the type
-- itself. This is relevant when the choice is a subtype mark or a
-- subtype indication.
-----------
-- Check --
@ -1509,8 +1509,8 @@ package body Sem_Case is
P := First (Static_Discrete_Predicate (Typ));
while Present (P) loop
-- Check that part of the predicate choice is included in
-- the given bounds.
-- Check that part of the predicate choice is included in the
-- given bounds.
if Expr_Value (High_Bound (P)) >= Expr_Value (Lo)
and then Expr_Value (Low_Bound (P)) <= Expr_Value (Hi)
@ -1643,8 +1643,8 @@ package body Sem_Case is
& "predicate as case alternative",
Choice, E, Suggest_Static => True);
-- Static predicate case. The bounds are
-- those of the given subtype.
-- Static predicate case. The bounds are those of
-- the given subtype.
else
Handle_Static_Predicate (E,
@ -1702,11 +1702,10 @@ package body Sem_Case is
end if;
end if;
if Has_Static_Predicate (E) then
-- Check applicable predicate values within the
-- bounds of the given range.
if Has_Static_Predicate (E) then
Handle_Static_Predicate (E, L, H);
else

14
gcc/ada/sem_ch13.adb
View File

@ -2823,6 +2823,19 @@ package body Sem_Ch13 is
goto Continue;
end Initializes;
-- Max_Queue_Length
when Aspect_Max_Queue_Length =>
Make_Aitem_Pragma
(Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Expression => Relocate_Node (Expr))),
Pragma_Name => Name_Max_Queue_Length);
Decorate (Aspect, Aitem);
Insert_Pragma (Aitem);
goto Continue;
-- Obsolescent
when Aspect_Obsolescent => declare
@ -9251,6 +9264,7 @@ package body Sem_Ch13 is
Aspect_Implicit_Dereference |
Aspect_Initial_Condition |
Aspect_Initializes |
Aspect_Max_Queue_Length |
Aspect_Obsolescent |
Aspect_Part_Of |
Aspect_Post |

81
gcc/ada/sem_prag.adb
View File

@ -17659,6 +17659,86 @@ package body Sem_Prag is
end loop;
end Main_Storage;
----------------------
-- Max_Queue_Length --
----------------------
-- pragma Max_Queue_Length (static_integer_EXPRESSION);
when Pragma_Max_Queue_Length => Max_Queue_Length : declare
Arg : Node_Id;
Entry_Decl : Node_Id;
Entry_Id : Entity_Id;
Val : Uint;
begin
GNAT_Pragma;
Check_Arg_Count (1);
Entry_Decl :=
Find_Related_Declaration_Or_Body (N, Do_Checks => True);
-- Entry declaration
if Nkind (Entry_Decl) = N_Entry_Declaration then
-- Entry illegally within a task
if Nkind (Parent (N)) = N_Task_Definition then
Error_Pragma ("pragma % cannot apply to task entries");
return;
end if;
Entry_Id := Unique_Defining_Entity (Entry_Decl);
-- Pragma illegally applied to an entry family
if Ekind (Entry_Id) = E_Entry_Family then
Error_Pragma ("pragma % cannot apply to entry families");
return;
end if;
-- Otherwise the pragma is associated with an illegal construct
else
Error_Pragma ("pragma % must apply to a protected entry");
return;
end if;
-- Mark the pragma as Ghost if the related subprogram is also
-- Ghost. This also ensures that any expansion performed further
-- below will produce Ghost nodes.
Mark_Pragma_As_Ghost (N, Entry_Id);
-- Analyze the Integer expression
Arg := Get_Pragma_Arg (Arg1);
Check_Arg_Is_OK_Static_Expression (Arg, Any_Integer);
Val := Expr_Value (Arg);
if Val <= 0 then
Error_Pragma_Arg
("argument for pragma% must be positive", Arg1);
elsif not UI_Is_In_Int_Range (Val) then
Error_Pragma_Arg
("argument for pragma% out of range of Integer", Arg1);
end if;
-- Manually subsitute the expression value of the pragma argument
-- if it not an integer literally because this is not taken care
-- of automatically elsewhere.
if Nkind (Arg) /= N_Integer_Literal then
Rewrite (Arg, Make_Integer_Literal (Sloc (Arg), Val));
end if;
Record_Rep_Item (Entry_Id, N);
end Max_Queue_Length;
-----------------
-- Memory_Size --
-----------------
@ -28642,6 +28722,7 @@ package body Sem_Prag is
Pragma_Machine_Attribute => -1,
Pragma_Main => -1,
Pragma_Main_Storage => -1,
Pragma_Max_Queue_Length => 0,
Pragma_Memory_Size => 0,
Pragma_No_Return => 0,
Pragma_No_Body => 0,

34
gcc/ada/sem_util.adb
View File

@ -8351,6 +8351,24 @@ package body Sem_Util is
pragma Assert (Name_Buffer (Name_Len + 1) = ' ');
end Get_Library_Unit_Name_String;
--------------------------
-- Get_Max_Queue_Length --
--------------------------
function Get_Max_Queue_Length (Id : Entity_Id) return Uint is
Prag : constant Entity_Id := Get_Pragma (Id, Pragma_Max_Queue_Length);
begin
-- A value of 0 represents no maximum specified and entries and entry
-- families with no Max_Queue_Length aspect or pragma defaults to it.
if not Has_Max_Queue_Length (Id) or else not Present (Prag) then
return Uint_0;
end if;
return Intval (Expression (First (Pragma_Argument_Associations (Prag))));
end Get_Max_Queue_Length;
------------------------
-- Get_Name_Entity_Id --
------------------------
@ -9648,15 +9666,25 @@ package body Sem_Util is
return False;
end Has_Interfaces;
--------------------------
-- Has_Max_Queue_Length --
--------------------------
function Has_Max_Queue_Length (Id : Entity_Id) return Boolean is
begin
return
Ekind (Id) = E_Entry
and then Present (Get_Pragma (Id, Pragma_Max_Queue_Length));
end Has_Max_Queue_Length;
---------------------------------
-- Has_No_Obvious_Side_Effects --
---------------------------------
function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean is
begin
-- For now, just handle literals, constants, and non-volatile
-- variables and expressions combining these with operators or
-- short circuit forms.
-- For now handle literals, constants, and non-volatile variables and
-- expressions combining these with operators or short circuit forms.
if Nkind (N) in N_Numeric_Or_String_Literal then
return True;

8
gcc/ada/sem_util.ads
View File

@ -931,6 +931,10 @@ package Sem_Util is
-- Retrieve the fully expanded name of the library unit declared by
-- Decl_Node into the name buffer.
function Get_Max_Queue_Length (Id : Entity_Id) return Uint;
-- Return the argument of pragma Max_Queue_Length or zero if the annotation
-- is not present. It is assumed that Id denotes an entry.
function Get_Name_Entity_Id (Id : Name_Id) return Entity_Id;
pragma Inline (Get_Name_Entity_Id);
-- An entity value is associated with each name in the name table. The
@ -1104,6 +1108,10 @@ package Sem_Util is
-- Use_Full_View controls if the check is done using its full view (if
-- available).
function Has_Max_Queue_Length (Id : Entity_Id) return Boolean;
-- Determine whether Id is subject to pragma Max_Queue_Length. It is
-- assumed that Id denotes an entry.
function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean;
-- This is a simple minded function for determining whether an expression
-- has no obvious side effects. It is used only for determining whether

2
gcc/ada/snames.ads-tmpl
View File

@ -575,6 +575,7 @@ package Snames is
Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT
Name_Main : constant Name_Id := N + $; -- GNAT
Name_Main_Storage : constant Name_Id := N + $; -- GNAT
Name_Max_Queue_Length : constant Name_Id := N + $; -- GNAT
Name_Memory_Size : constant Name_Id := N + $; -- Ada 83
Name_No_Body : constant Name_Id := N + $; -- GNAT
Name_No_Elaboration_Code_All : constant Name_Id := N + $; -- GNAT
@ -1904,6 +1905,7 @@ package Snames is
Pragma_Machine_Attribute,
Pragma_Main,
Pragma_Main_Storage,
Pragma_Max_Queue_Length,
Pragma_Memory_Size,
Pragma_No_Body,
Pragma_No_Elaboration_Code_All,