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

[multiple changes] 

2012-06-14  Robert Dewar  <dewar@adacore.com>

	* exp_ch7.adb, exp_util.adb, sem_aux.ads, exp_ch9.adb,
	sem_ch10.adb, freeze.adb, sem_util.adb, exp_ch4.adb,
	s-taprop-dummy.adb: Minor reformatting.

2012-06-14  Vincent Pucci  <pucci@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Lock_Free
	attribute case added.
	* par-prag.adb (Prag): Lock_Free pragma case added.
	* sem_attr.adb (Analyze_Attribute_Reference): Lock_Free attribute
	case added.
	* sem_ch13.adb (Analyze_Aspect_Specifications): Record_Rep_Item
	call added for Aspect_Lock_Free.
	* sem_ch9.adb (Allows_Lock_Free_Implementation): New Lock_Free
	error messages for subprogram bodies.
	(Lock_Free_Disabled): New routine.
	(Analyze_Protected_Body): Call to Lock_Free_Disabled added.
	* sem_prag.adb (Analyze_Pragma): Lock_Free pragma case added.
	* snames.adb-tmpl (Get_Pragma_Id): Name_Lock_Free case added.
	(Is_Pragma_Name): Name_Lock_Free case added.
	* snames.ads-tmpl: Attribute_Lock_Free and Pragma_Lock_Free added.

2012-06-14  Ed Schonberg  <schonberg@adacore.com>

	* a-coorma.adb, a-cborma.adb, a-cbhama.adb, a-ciorma.adb: Add missing
	aliased keyword.

2012-06-14  Bob Duff  <duff@adacore.com>

	* lib.ads, lib.adb, sem.adb (Write_Unit_Info): Move this
	procedure from Sem body to Lib spec, so it can be used for
	debugging elsewhere.

2012-06-14  Ed Schonberg  <schonberg@adacore.com>

	* sem_ch6.adb (Check_Conformance): Add Ada 2012 check on mode
	conformance: "aliased" must apply to both or neither formal
	parameters.

From-SVN: r188609
This commit is contained in:
Arnaud Charlet 2012-06-14 12:49:59 +02:00
parent 758ad97333
commit 2a290fec3d
26 changed files with 408 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
gcc/ada/ChangeLog
View File

@ -1,3 +1,44 @@
2012-06-14 Robert Dewar <dewar@adacore.com>
* exp_ch7.adb, exp_util.adb, sem_aux.ads, exp_ch9.adb,
sem_ch10.adb, freeze.adb, sem_util.adb, exp_ch4.adb,
s-taprop-dummy.adb: Minor reformatting.
2012-06-14 Vincent Pucci <pucci@adacore.com>
* exp_attr.adb (Expand_N_Attribute_Reference): Lock_Free
attribute case added.
* par-prag.adb (Prag): Lock_Free pragma case added.
* sem_attr.adb (Analyze_Attribute_Reference): Lock_Free attribute
case added.
* sem_ch13.adb (Analyze_Aspect_Specifications): Record_Rep_Item
call added for Aspect_Lock_Free.
* sem_ch9.adb (Allows_Lock_Free_Implementation): New Lock_Free
error messages for subprogram bodies.
(Lock_Free_Disabled): New routine.
(Analyze_Protected_Body): Call to Lock_Free_Disabled added.
* sem_prag.adb (Analyze_Pragma): Lock_Free pragma case added.
* snames.adb-tmpl (Get_Pragma_Id): Name_Lock_Free case added.
(Is_Pragma_Name): Name_Lock_Free case added.
* snames.ads-tmpl: Attribute_Lock_Free and Pragma_Lock_Free added.
2012-06-14 Ed Schonberg <schonberg@adacore.com>
* a-coorma.adb, a-cborma.adb, a-cbhama.adb, a-ciorma.adb: Add missing
aliased keyword.
2012-06-14 Bob Duff <duff@adacore.com>
* lib.ads, lib.adb, sem.adb (Write_Unit_Info): Move this
procedure from Sem body to Lib spec, so it can be used for
debugging elsewhere.
2012-06-14 Ed Schonberg <schonberg@adacore.com>
* sem_ch6.adb (Check_Conformance): Add Ada 2012 check on mode
conformance: "aliased" must apply to both or neither formal
parameters.
2012-06-14 Gary Dismukes <dismukes@adacore.com>
* exp_ch9.adb: Minor reformatting.

4
gcc/ada/a-cbhama.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2012, 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- --
@ -220,7 +220,7 @@ package body Ada.Containers.Bounded_Hashed_Maps is
end Constant_Reference;
function Constant_Reference
(Container : Map;
(Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type
is
Node : constant Count_Type := Key_Ops.Find (Container, Key);

4
gcc/ada/a-cborma.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 2004-2011, Free Software Foundation, Inc. --
-- Copyright (C) 2004-2012, 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- --
@ -432,7 +432,7 @@ package body Ada.Containers.Bounded_Ordered_Maps is
end Constant_Reference;
function Constant_Reference
(Container : Map;
(Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type
is
Node : constant Count_Type := Key_Ops.Find (Container, Key);

2
gcc/ada/a-ciorma.adb
View File

@ -410,7 +410,7 @@ package body Ada.Containers.Indefinite_Ordered_Maps is
end Constant_Reference;
function Constant_Reference
(Container : Map;
(Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type
is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);

2
gcc/ada/a-coorma.adb
View File

@ -370,7 +370,7 @@ package body Ada.Containers.Ordered_Maps is
end Constant_Reference;
function Constant_Reference
(Container : Map;
(Container : aliased Map;
Key : Key_Type) return Constant_Reference_Type
is
Node : constant Node_Access := Key_Ops.Find (Container.Tree, Key);

23
gcc/ada/exp_attr.adb
View File

@ -3065,6 +3065,29 @@ package body Exp_Attr is
end if;
end;
---------------
-- Lock_Free --
---------------
-- Rewrite the attribute reference with the value of Uses_Lock_Free
when Attribute_Lock_Free => Lock_Free : declare
Val : Entity_Id;
begin
if Uses_Lock_Free (Ptyp) then
Val := Standard_True;
else
Val := Standard_False;
end if;
Rewrite (N,
New_Occurrence_Of (Val, Loc));
Analyze_And_Resolve (N, Standard_Boolean);
end Lock_Free;
-------------
-- Machine --
-------------

6
gcc/ada/exp_ch4.adb
View File

@ -4277,8 +4277,7 @@ package body Exp_Ch4 is
-- is a finalization flag created to service expression Expr.
function Is_Controlled_Function_Call (Expr : Node_Id) return Boolean;
-- Determine whether an expression is a rewritten controlled function
-- call.
-- Determine if expression Expr is a rewritten controlled function call
------------------------
-- Create_Alternative --
@ -4431,7 +4430,8 @@ package body Exp_Ch4 is
-- handling.
if Is_Controlled_Function_Call (Thenx)
or else Is_Controlled_Function_Call (Elsex)
or else
Is_Controlled_Function_Call (Elsex)
then
Flag_Id := Make_Temporary (Loc, 'F');

16
gcc/ada/exp_ch7.adb
View File

@ -1892,14 +1892,13 @@ package body Exp_Ch7 is
then
Processing_Actions (Has_No_Init => True);
-- Processing for intermediate results of conditional
-- expressions where one of the alternatives uses a controlled
-- function call.
-- Process intermediate results of conditional expression with
-- one of the alternatives using a controlled function call.
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Defining_Identifier
N_Defining_Identifier
and then Present (Expr)
and then Nkind (Expr) = N_Null
then
@ -2728,7 +2727,7 @@ package body Exp_Ch7 is
-- end if;
if Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
N_Object_Declaration
then
Fin_Stmts := New_List (
Make_If_Statement (Loc,
@ -2736,12 +2735,11 @@ package body Exp_Ch7 is
Make_Op_Ne (Loc,
Left_Opnd => New_Reference_To (Obj_Id, Loc),
Right_Opnd => Make_Null (Loc)),
Then_Statements => Fin_Stmts));
-- Return objects use a flag to aid their potential
-- finalization when the enclosing function fails to return
-- properly. Generate:
-- Return objects use a flag to aid in processing their
-- potential finalization when the enclosing function fails
-- to return properly. Generate:
-- if not Flag then
-- <object finalization statements>

2
gcc/ada/exp_ch9.adb
View File

@ -13342,7 +13342,7 @@ package body Exp_Ch9 is
-- or attribute definition clause, or there is an Interrupt_Priority
-- rep item and no Priority rep item, and we set the ceiling to
-- Interrupt_Priority'Last, an implementation-defined value, see
-- D.3(10).
-- (RM D.3(10)).
if Has_Rep_Item (Ptyp, Name_Priority) then
declare

2
gcc/ada/exp_util.adb
View File

@ -7181,7 +7181,7 @@ package body Exp_Util is
elsif Is_Access_Type (Obj_Typ)
and then Present (Status_Flag_Or_Transient_Decl (Obj_Id))
and then Nkind (Status_Flag_Or_Transient_Decl (Obj_Id)) =
N_Object_Declaration
N_Object_Declaration
and then Is_Finalizable_Transient
(Status_Flag_Or_Transient_Decl (Obj_Id), Decl)
then

5
gcc/ada/freeze.adb
View File

@ -2168,8 +2168,7 @@ package body Freeze is
-- Deal with Bit_Order aspect specifying a non-default bit order
ADC :=
Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
ADC := Get_Attribute_Definition_Clause (Rec, Attribute_Bit_Order);
if Present (ADC) and then Base_Type (Rec) = Rec then
if not Placed_Component then
@ -2180,7 +2179,7 @@ package body Freeze is
-- Here is where we do the processing for reversed bit order
elsif Reverse_Bit_Order (Rec)
and then not Reverse_Storage_Order (Rec)
and then not Reverse_Storage_Order (Rec)
then
Adjust_Record_For_Reverse_Bit_Order (Rec);

81
gcc/ada/lib.adb
View File

@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -37,6 +37,7 @@ with Atree; use Atree;
with Csets; use Csets;
with Einfo; use Einfo;
with Fname; use Fname;
with Nlists; use Nlists;
with Output; use Output;
with Sinfo; use Sinfo;
with Sinput; use Sinput;
@ -1155,4 +1156,82 @@ package body Lib is
Version_Ref.Append (S);
end Version_Referenced;
---------------------
-- Write_Unit_Info --
---------------------
procedure Write_Unit_Info
(Unit_Num : Unit_Number_Type;
Item : Node_Id;
Prefix : String := "";
Withs : Boolean := False)
is
begin
Write_Str (Prefix);
Write_Unit_Name (Unit_Name (Unit_Num));
Write_Str (", unit ");
Write_Int (Int (Unit_Num));
Write_Str (", ");
Write_Int (Int (Item));
Write_Str ("=");
Write_Str (Node_Kind'Image (Nkind (Item)));
if Item /= Original_Node (Item) then
Write_Str (", orig = ");
Write_Int (Int (Original_Node (Item)));
Write_Str ("=");
Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
end if;
Write_Eol;
-- Skip the rest if we're not supposed to print the withs
if not Withs then
return;
end if;
declare
Context_Item : Node_Id;
begin
Context_Item := First (Context_Items (Cunit (Unit_Num)));
while Present (Context_Item)
and then (Nkind (Context_Item) /= N_With_Clause
or else Limited_Present (Context_Item))
loop
Context_Item := Next (Context_Item);
end loop;
if Present (Context_Item) then
Indent;
Write_Line ("withs:");
Indent;
while Present (Context_Item) loop
if Nkind (Context_Item) = N_With_Clause
and then not Limited_Present (Context_Item)
then
pragma Assert (Present (Library_Unit (Context_Item)));
Write_Unit_Name
(Unit_Name
(Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
if Implicit_With (Context_Item) then
Write_Str (" -- implicit");
end if;
Write_Eol;
end if;
Context_Item := Next (Context_Item);
end loop;
Outdent;
Write_Line ("end withs");
Outdent;
end if;
end;
end Write_Unit_Info;
end Lib;

11
gcc/ada/lib.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1992-2011, Free Software Foundation, Inc. --
-- Copyright (C) 1992-2012, 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- --
@ -673,6 +673,15 @@ package Lib is
-- that file not being compiled. The predicate Generic_May_Lack_ALI is
-- True for those generic units for which missing ALI files are allowed.
procedure Write_Unit_Info
(Unit_Num : Unit_Number_Type;
Item : Node_Id;
Prefix : String := "";
Withs : Boolean := False);
-- Print out debugging information about the unit. Prefix precedes the rest
-- of the printout. If Withs is True, we print out units with'ed by this
-- unit (not counting limited withs).
private
pragma Inline (Cunit);
pragma Inline (Cunit_Entity);

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

@ -1183,6 +1183,7 @@ begin
Pragma_Linker_Destructor |
Pragma_Linker_Options |
Pragma_Linker_Section |
Pragma_Lock_Free |
Pragma_Locking_Policy |
Pragma_Long_Float |
Pragma_Machine_Attribute |

17
gcc/ada/s-taprop-dummy.adb
View File

@ -46,27 +46,30 @@ package body System.Task_Primitives.Operations is
pragma Warnings (Off);
-- Turn off warnings since so many unreferenced parameters
--------------------
-- Local Packages --
--------------------
--------------
-- Specific --
--------------
-- Package Specific contains target specific routines, and the body of
-- this package is target specific.
package Specific is
procedure Set (Self_Id : Task_Id);
pragma Inline (Set);
-- Set the self id for the current task
end Specific;
package body Specific is
---------
-- Set --
---------
procedure Set (Self_Id : Task_Id) is
begin
null;
end Set;
end Specific;
-- The body of this package is target specific
----------------------------------
-- ATCB allocation/deallocation --

87
gcc/ada/sem.adb
View File

@ -91,15 +91,6 @@ package body Sem is
-- of this unit, since they count as dependences on their parent library
-- item. CU must be an N_Compilation_Unit whose Unit is not an N_Subunit.
procedure Write_Unit_Info
(Unit_Num : Unit_Number_Type;
Item : Node_Id;
Prefix : String := "";
Withs : Boolean := False);
-- Print out debugging information about the unit. Prefix precedes the rest
-- of the printout. If Withs is True, we print out units with'ed by this
-- unit (not counting limited withs).
-------------
-- Analyze --
-------------
@ -2290,82 +2281,4 @@ package body Sem is
end loop;
end Walk_Withs_Immediate;
---------------------
-- Write_Unit_Info --
---------------------
procedure Write_Unit_Info
(Unit_Num : Unit_Number_Type;
Item : Node_Id;
Prefix : String := "";
Withs : Boolean := False)
is
begin
Write_Str (Prefix);
Write_Unit_Name (Unit_Name (Unit_Num));
Write_Str (", unit ");
Write_Int (Int (Unit_Num));
Write_Str (", ");
Write_Int (Int (Item));
Write_Str ("=");
Write_Str (Node_Kind'Image (Nkind (Item)));
if Item /= Original_Node (Item) then
Write_Str (", orig = ");
Write_Int (Int (Original_Node (Item)));
Write_Str ("=");
Write_Str (Node_Kind'Image (Nkind (Original_Node (Item))));
end if;
Write_Eol;
-- Skip the rest if we're not supposed to print the withs
if not Withs then
return;
end if;
declare
Context_Item : Node_Id;
begin
Context_Item := First (Context_Items (Cunit (Unit_Num)));
while Present (Context_Item)
and then (Nkind (Context_Item) /= N_With_Clause
or else Limited_Present (Context_Item))
loop
Context_Item := Next (Context_Item);
end loop;
if Present (Context_Item) then
Indent;
Write_Line ("withs:");
Indent;
while Present (Context_Item) loop
if Nkind (Context_Item) = N_With_Clause
and then not Limited_Present (Context_Item)
then
pragma Assert (Present (Library_Unit (Context_Item)));
Write_Unit_Name
(Unit_Name
(Get_Cunit_Unit_Number (Library_Unit (Context_Item))));
if Implicit_With (Context_Item) then
Write_Str (" -- implicit");
end if;
Write_Eol;
end if;
Context_Item := Next (Context_Item);
end loop;
Outdent;
Write_Line ("end withs");
Outdent;
end if;
end;
end Write_Unit_Info;
end Sem;

22
gcc/ada/sem_attr.adb
View File

@ -3569,6 +3569,19 @@ package body Sem_Attr is
Check_Array_Type;
Set_Etype (N, Universal_Integer);
---------------
-- Lock_Free --
---------------
when Attribute_Lock_Free =>
Check_E0;
Set_Etype (N, Standard_Boolean);
if not Is_Protected_Type (P_Type) then
Error_Attr_P
("prefix of % attribute must be a protected object");
end if;
-------------
-- Machine --
-------------
@ -6767,6 +6780,15 @@ package body Sem_Attr is
True);
end if;
---------------
-- Lock_Free --
---------------
-- Lock_Free attribute is a Boolean, thus no need to fold here.
when Attribute_Lock_Free =>
null;
----------
-- Last --
----------

22
gcc/ada/sem_aux.ads
View File

@ -163,7 +163,7 @@ package Sem_Aux is
-- Searches the Rep_Item chain for a given entity E, for an instance of a
-- rep item (pragma, attribute definition clause, or aspect specification)
-- whose name matches the given name Nam. If Check_Parents is False then it
-- only returns rep item that has been directly specified to E (and not
-- only returns rep item that has been directly specified for E (and not
-- inherited from its parents, if any). If one is found, it is returned,
-- otherwise Empty is returned. A special case is that when Nam is
-- Name_Priority, the call will also find Interrupt_Priority.
@ -172,11 +172,11 @@ package Sem_Aux is
(E : Entity_Id;
Nam : Name_Id;
Check_Parents : Boolean := True) return Node_Id;
-- Searches the Rep_Item chain for a given entity E, for an instance of a
-- representation pragma whose name matches the given name Nam. If
-- Searches the Rep_Item chain for a given entity E, for an instance
-- of a representation pragma whose name matches the given name Nam. If
-- Check_Parents is False then it only returns representation pragma that
-- has been directly specified to E (and not inherited from its parents, if
-- any). If one is found, it is returned, otherwise Empty is returned. A
-- has been directly specified for E (and not inherited from its parents,
-- if any). If one is found, it is returned, otherwise Empty is returned. A
-- special case is that when Nam is Name_Priority, the call will also find
-- Interrupt_Priority.
@ -186,10 +186,10 @@ package Sem_Aux is
Check_Parents : Boolean := True) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance of a
-- rep item (pragma, attribute definition clause, or aspect specification)
-- with the given name Nam. If Check_Parents is False then it only returns
-- rep item that has been directly specified to E (and not inherited from
-- its parents, if any). If found then True is returned, otherwise False
-- indicates that no matching entry was found.
-- with the given name Nam. If Check_Parents is False then it only checks
-- for a rep item that has been directly specified for E (and not inherited
-- from its parents, if any). If found then True is returned, otherwise
-- False indicates that no matching entry was found.
function Has_Rep_Pragma
(E : Entity_Id;
@ -197,8 +197,8 @@ package Sem_Aux is
Check_Parents : Boolean := True) return Boolean;
-- Searches the Rep_Item chain for the given entity E, for an instance of a
-- representation pragma with the given name Nam. If Check_Parents is False
-- then it only returns representation pragma that has been directly
-- specified to E (and not inherited from its parents, if any). If found
-- then it only checks for a representation pragma that has been directly
-- specified for E (and not inherited from its parents, if any). If found
-- then True is returned, otherwise False indicates that no matching entry
-- was found.

1
gcc/ada/sem_ch10.adb
View File

@ -1261,7 +1261,6 @@ package body Sem_Ch10 is
and then Warn_On_Obsolescent_Feature
and then Nkind (Unit_Node) not in N_Generic_Instantiation
then
-- Push current compilation unit as scope, so that the test for
-- being within an obsolescent unit will work correctly. The check
-- is not performed within an instantiation, because the warning

2
gcc/ada/sem_ch13.adb
View File

@ -1445,6 +1445,8 @@ package body Sem_Ch13 is
then
Set_Uses_Lock_Free (E);
end if;
Record_Rep_Item (E, Aspect);
end if;
goto Continue;

12
gcc/ada/sem_ch6.adb
View File

@ -5503,6 +5503,18 @@ package body Sem_Ch6 is
end if;
end if;
-- Ada 2012: mode conformance also requires that formal parameters
-- be both aliased, or neither.
if Ctype >= Mode_Conformant
and then Ada_Version >= Ada_2012
then
if Is_Aliased (Old_Formal) /= Is_Aliased (New_Formal) then
Conformance_Error
("\aliased parameter mismatch!", New_Formal);
end if;
end if;
if Ctype = Fully_Conformant then
-- Names must match. Error message is more accurate if we do

137
gcc/ada/sem_ch9.adb
View File

@ -23,7 +23,6 @@
-- --
------------------------------------------------------------------------------
with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@ -263,16 +262,41 @@ package body Sem_Ch9 is
begin
-- Function calls and attribute references must be static
if Nkind_In (N, N_Attribute_Reference, N_Function_Call)
if Nkind (N) = N_Attribute_Reference
and then not Is_Static_Expression (N)
then
if Complain then
Error_Msg_N
("non-static attribute reference not allowed",
N);
end if;
return Abandon;
elsif Nkind (N) = N_Function_Call
and then not Is_Static_Expression (N)
then
if Complain then
Error_Msg_N ("non-static function call not allowed",
N);
end if;
return Abandon;
-- Loop statements and procedure calls are prohibited
elsif Nkind_In (N, N_Loop_Statement,
N_Procedure_Call_Statement)
then
elsif Nkind (N) = N_Loop_Statement then
if Complain then
Error_Msg_N ("loop not allowed", N);
end if;
return Abandon;
elsif Nkind (N) = N_Procedure_Call_Statement then
if Complain then
Error_Msg_N ("procedure call not allowed", N);
end if;
return Abandon;
-- References
@ -295,6 +319,12 @@ package body Sem_Ch9 is
and then not Scope_Within_Or_Same (Scope (Id),
Protected_Body_Subprogram (Sub_Id))
then
if Complain then
Error_Msg_NE
("reference to global variable& not allowed",
N, Id);
end if;
return Abandon;
-- Prohibit non-scalar out parameters (scalar
@ -305,6 +335,12 @@ package body Sem_Ch9 is
and then not Is_Elementary_Type (Etype (Id))
and then Scope_Within_Or_Same (Scope (Id), Sub_Id)
then
if Complain then
Error_Msg_NE
("non-elementary out parameter& not allowed",
N, Id);
end if;
return Abandon;
-- A protected subprogram may reference only one
@ -327,6 +363,13 @@ package body Sem_Ch9 is
-- body.
elsif Comp /= Id then
if Complain then
Error_Msg_N
("only one protected component " &
"allowed",
N);
end if;
return Abandon;
end if;
end if;
@ -352,6 +395,13 @@ package body Sem_Ch9 is
-- body.
elsif Comp /= Prival_Link (Id) then
if Complain then
Error_Msg_N
("only one protected component " &
"allowed",
N);
end if;
return Abandon;
end if;
end if;
@ -1375,7 +1425,6 @@ package body Sem_Ch9 is
procedure Analyze_Protected_Body (N : Node_Id) is
Body_Id : constant Entity_Id := Defining_Identifier (N);
Aspect : Node_Id;
Last_E : Entity_Id;
Spec_Id : Entity_Id;
@ -1390,6 +1439,50 @@ package body Sem_Ch9 is
-- differs from Spec_Id in the case of a single protected object, since
-- Spec_Id is set to the protected type in this case).
function Lock_Free_Disabled return Boolean;
-- This routine returns False if the protected object has a Lock_Free
-- aspect specification or a Lock_Free pragma that turns off the
-- lock-free implementation (e.g. whose expression is False).
------------------------
-- Lock_Free_Disabled --
------------------------
function Lock_Free_Disabled return Boolean is
Ritem : constant Node_Id :=
Get_Rep_Item
(Spec_Id, Name_Lock_Free, Check_Parents => False);
begin
if Present (Ritem) then
-- Pragma with one argument
if Nkind (Ritem) = N_Pragma
and then Present (Pragma_Argument_Associations (Ritem))
then
return
Is_False (Static_Boolean
(Expression (First (Pragma_Argument_Associations (Ritem)))));
-- Aspect Specification with expression present
elsif Nkind (Ritem) = N_Aspect_Specification
and then Present (Expression (Ritem))
then
return Is_False (Static_Boolean (Expression (Ritem)));
-- Otherwise, return False
else
return False;
end if;
end if;
return False;
end Lock_Free_Disabled;
-- Start of processing for Analyze_Protected_Body
begin
Tasking_Used := True;
Set_Ekind (Body_Id, E_Protected_Body);
@ -1450,37 +1543,21 @@ package body Sem_Ch9 is
Process_End_Label (N, 't', Ref_Id);
End_Scope;
-- Turn on/off the lock-free implementation for the protected object
-- Look for a Lock_Free aspect with a False expression that disables the
-- lock-free implementation.
Aspect := First (Aspect_Specifications (Parent (Spec_Id)));
while Present (Aspect) loop
if Get_Aspect_Id (Chars (Identifier (Aspect))) = Aspect_Lock_Free
and then Present (Expression (Aspect))
and then Entity (Expression (Aspect)) = Standard_False
then
return;
end if;
Next (Aspect);
end loop;
-- When a Lock_Free aspect forces the lock-free implementation, verify
-- the protected body meets all the restrictions, otherwise
-- Allows_Lock_Free_Implementation issues an error message.
-- When a Lock_Free aspect specification/pragma forces the lock-free
-- implementation, verify the protected body meets all the restrictions,
-- otherwise Allows_Lock_Free_Implementation issues an error message.
if Uses_Lock_Free (Spec_Id) then
if not Allows_Lock_Free_Implementation (N, Complain => True) then
return;
end if;
-- In other cases, check both the protected declaration and body satisfy
-- the lock-free restrictions.
-- In other cases, if there is no aspect specification/pragma that
-- disables the lock-free implementation, check both the protected
-- declaration and body satisfy the lock-free restrictions.
elsif Allows_Lock_Free_Implementation (Parent (Spec_Id))
elsif not Lock_Free_Disabled
and then Allows_Lock_Free_Implementation (Parent (Spec_Id))
and then Allows_Lock_Free_Implementation (N)
then
Set_Uses_Lock_Free (Spec_Id);

49
gcc/ada/sem_prag.adb
View File

@ -11118,6 +11118,54 @@ package body Sem_Prag is
when Pragma_List =>
null;
---------------
-- Lock_Free --
---------------
-- pragma Lock_Free [(Boolean_EXPRESSION)];
when Pragma_Lock_Free => Lock_Free : declare
P : constant Node_Id := Parent (N);
Arg : Node_Id;
Ent : Entity_Id;
Val : Boolean;
begin
Check_No_Identifiers;
Check_At_Most_N_Arguments (1);
-- Protected definition case
if Nkind (P) = N_Protected_Definition then
Ent := Defining_Identifier (Parent (P));
-- One argument
if Arg_Count = 1 then
Arg := Get_Pragma_Arg (Arg1);
Val := Is_True (Static_Boolean (Arg));
-- Zero argument. In this case the expression is considered to
-- be True.
else
Val := True;
end if;
-- Check duplicate pragma before we chain the pragma in the Rep
-- Item chain of Ent.
Check_Duplicate_Pragma (Ent);
Record_Rep_Item (Ent, N);
Set_Uses_Lock_Free (Ent, Val);
-- Anything else is incorrect
else
Pragma_Misplaced;
end if;
end Lock_Free;
--------------------
-- Locking_Policy --
--------------------
@ -15212,6 +15260,7 @@ package body Sem_Prag is
Pragma_Linker_Options => -1,
Pragma_Linker_Section => -1,
Pragma_List => -1,
Pragma_Lock_Free => -1,
Pragma_Locking_Policy => -1,
Pragma_Long_Float => -1,
Pragma_Machine_Attribute => -1,

7
gcc/ada/sem_util.adb
View File

@ -7745,14 +7745,13 @@ package body Sem_Util is
when N_String_Literal =>
return Is_Internally_Generated_Renaming (Parent (N));
-- AI05-0003: in Ada 2012, a qualified expression is a name.
-- This allows disambiguation of function calls and the use of
-- aggregates in more contexts.
-- AI05-0003: In Ada 2012 a qualified expression is a name.
-- This allows disambiguation of function calls and the use
-- of aggregates in more contexts.
when N_Qualified_Expression =>
if Ada_Version < Ada_2012 then
return False;
else
return Is_Object_Reference (Expression (N))
or else Nkind (Expression (N)) = N_Aggregate;

3
gcc/ada/snames.adb-tmpl
View File

@ -219,6 +219,8 @@ package body Snames is
return Pragma_Interface;
elsif N = Name_Interrupt_Priority then
return Pragma_Interrupt_Priority;
elsif N = Name_Lock_Free then
return Pragma_Lock_Free;
elsif N = Name_Priority then
return Pragma_Priority;
elsif N = Name_Relative_Deadline then
@ -421,6 +423,7 @@ package body Snames is
or else N = Name_Fast_Math
or else N = Name_Interface
or else N = Name_Interrupt_Priority
or else N = Name_Lock_Free
or else N = Name_Relative_Deadline
or else N = Name_Priority
or else N = Name_Storage_Size

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

@ -142,7 +142,6 @@ package Snames is
Name_Dimension : constant Name_Id := N + $;
Name_Dimension_System : constant Name_Id := N + $;
Name_Dynamic_Predicate : constant Name_Id := N + $;
Name_Lock_Free : constant Name_Id := N + $;
Name_Post : constant Name_Id := N + $;
Name_Pre : constant Name_Id := N + $;
Name_Static_Predicate : constant Name_Id := N + $;
@ -522,6 +521,12 @@ package Snames is
Name_Linker_Options : constant Name_Id := N + $;
Name_Linker_Section : constant Name_Id := N + $; -- GNAT
Name_List : constant Name_Id := N + $;
-- Note: Lock_Free is not in this list because its name matches the name of
-- the corresponding attribute. However, it is included in the definition
-- of the type Pragma_Id, and the functions Get_Pragma_Id and Is_Pragma_Id
-- correctly recognize and process Lock_Free. Lock_Free is a GNAT pragma.
Name_Machine_Attribute : constant Name_Id := N + $; -- GNAT
Name_Main : constant Name_Id := N + $; -- GNAT
Name_Main_Storage : constant Name_Id := N + $; -- GNAT
@ -810,6 +815,7 @@ package Snames is
Name_Last_Valid : constant Name_Id := N + $; -- Ada 12
Name_Leading_Part : constant Name_Id := N + $;
Name_Length : constant Name_Id := N + $;
Name_Lock_Free : constant Name_Id := N + $; -- GNAT
Name_Machine_Emax : constant Name_Id := N + $;
Name_Machine_Emin : constant Name_Id := N + $;
Name_Machine_Mantissa : constant Name_Id := N + $;
@ -1388,6 +1394,7 @@ package Snames is
Attribute_Last_Valid,
Attribute_Leading_Part,
Attribute_Length,
Attribute_Lock_Free,
Attribute_Machine_Emax,
Attribute_Machine_Emin,
Attribute_Machine_Mantissa,
@ -1774,6 +1781,7 @@ package Snames is
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Interrupt_Priority,
Pragma_Lock_Free,
Pragma_Priority,
Pragma_Storage_Size,
Pragma_Storage_Unit,
@ -1853,8 +1861,8 @@ package Snames is
function Is_Pragma_Name (N : Name_Id) return Boolean;
-- Test to see if the name N is the name of a recognized pragma. Note that
-- pragmas AST_Entry, CPU, Dispatching_Domain, Fast_Math,
-- Interrupt_Priority, Priority, Storage_Size, and Storage_Unit are
-- recognized as pragmas by this function even though their names are
-- Interrupt_Priority, Lock_Free, Priority, Storage_Size, and Storage_Unit
-- are recognized as pragmas by this function even though their names are
-- separate from the other pragma names. For this reason, clients should
-- always use this function, rather than do range tests on Name_Id values.
@ -1895,8 +1903,9 @@ package Snames is
-- if N is not a name of a known (Ada defined or GNAT-specific) pragma.
-- Note that the function also works correctly for names of pragmas that
-- are not included in the main list of pragma Names (AST_Entry, CPU,
-- Dispatching_Domain, Interrupt_Priority, Priority, Storage_Size, and
-- Storage_Unit (e.g. Name_Storage_Size returns Pragma_Storage_Size).
-- Dispatching_Domain, Interrupt_Priority, Lock_Free, Priority,
-- Storage_Size, and Storage_Unit (e.g. Name_Storage_Size returns
-- Pragma_Storage_Size).
function Get_Queuing_Policy_Id (N : Name_Id) return Queuing_Policy_Id;
-- Returns Id of queuing policy corresponding to given name. It is an error