+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.
-- --
-- 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- --
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);
-- --
-- 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- --
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);
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);
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);
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 --
-------------
-- 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 --
-- 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');
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
-- 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,
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>
-- 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
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
-- 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
-- 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);
-- --
-- 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- --
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;
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;
-- --
-- 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- --
-- 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);
Pragma_Linker_Destructor |
Pragma_Linker_Options |
Pragma_Linker_Section |
+ Pragma_Lock_Free |
Pragma_Locking_Policy |
Pragma_Long_Float |
Pragma_Machine_Attribute |
pragma Warnings (Off);
-- Turn off warnings since so many unreferenced parameters
- --------------------
- -- Local Packages --
- --------------------
+ --------------
+ -- Specific --
+ --------------
- package Specific is
+ -- 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 --
-- 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 --
-------------
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;
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 --
-------------
True);
end if;
+ ---------------
+ -- Lock_Free --
+ ---------------
+
+ -- Lock_Free attribute is a Boolean, thus no need to fold here.
+
+ when Attribute_Lock_Free =>
+ null;
+
----------
-- Last --
----------
-- 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.
(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.
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;
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.
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
then
Set_Uses_Lock_Free (E);
end if;
+
+ Record_Rep_Item (E, Aspect);
end if;
goto Continue;
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
-- --
------------------------------------------------------------------------------
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
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
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
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
-- 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;
-- 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;
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;
-- 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);
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);
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 --
--------------------
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,
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;
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
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
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 + $;
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
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 + $;
Attribute_Last_Valid,
Attribute_Leading_Part,
Attribute_Length,
+ Attribute_Lock_Free,
Attribute_Machine_Emax,
Attribute_Machine_Emin,
Attribute_Machine_Mantissa,
Pragma_Fast_Math,
Pragma_Interface,
Pragma_Interrupt_Priority,
+ Pragma_Lock_Free,
Pragma_Priority,
Pragma_Storage_Size,
Pragma_Storage_Unit,
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.
-- 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
projects / gcc.git / commitdiff