-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2022, 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 Aspects; use Aspects;
-with Atree; use Atree;
-with Checks; use Checks;
-with Contracts; use Contracts;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Ch9; use Exp_Ch9;
-with Elists; use Elists;
-with Freeze; use Freeze;
-with Layout; use Layout;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Nmake; use Nmake;
-with Opt; use Opt;
-with Restrict; use Restrict;
-with Rident; use Rident;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Aux; use Sem_Aux;
-with Sem_Ch3; use Sem_Ch3;
-with Sem_Ch5; use Sem_Ch5;
-with Sem_Ch6; use Sem_Ch6;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Ch13; use Sem_Ch13;
-with Sem_Elab; use Sem_Elab;
-with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
-with Sem_Res; use Sem_Res;
-with Sem_Type; use Sem_Type;
-with Sem_Util; use Sem_Util;
-with Sem_Warn; use Sem_Warn;
-with Snames; use Snames;
-with Stand; use Stand;
-with Sinfo; use Sinfo;
+with Aspects; use Aspects;
+with Atree; use Atree;
+with Checks; use Checks;
+with Contracts; use Contracts;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Exp_Ch9; use Exp_Ch9;
+with Elists; use Elists;
+with Freeze; use Freeze;
+with Layout; use Layout;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Nmake; use Nmake;
+with Opt; use Opt;
+with Restrict; use Restrict;
+with Rident; use Rident;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
+with Sem_Ch3; use Sem_Ch3;
+with Sem_Ch5; use Sem_Ch5;
+with Sem_Ch6; use Sem_Ch6;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Ch13; use Sem_Ch13;
+with Sem_Elab; use Sem_Elab;
+with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
+with Sem_Res; use Sem_Res;
+with Sem_Type; use Sem_Type;
+with Sem_Util; use Sem_Util;
+with Sem_Warn; use Sem_Warn;
+with Snames; use Snames;
+with Stand; use Stand;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
with Style;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Targparm; use Targparm;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Sem_Ch9 is
-- when Lock_Free_Given is True.
begin
- pragma Assert (Nkind_In (N, N_Protected_Type_Declaration,
- N_Protected_Body));
-
- -- The lock-free implementation is currently enabled through a debug
- -- flag. When Lock_Free_Given is True, an aspect Lock_Free forces the
- -- lock-free implementation. In that case, the debug flag is not needed.
-
- if not Lock_Free_Given and then not Debug_Flag_9 then
- return False;
- end if;
+ pragma Assert
+ (Nkind (N) in N_Protected_Type_Declaration | N_Protected_Body);
-- Get the number of errors detected by the compiler so far
elsif Nkind (Decl) = N_Subprogram_Declaration
and then
Nkind (Specification (Decl)) = N_Procedure_Specification
- and then
- Present (Parameter_Specifications (Specification (Decl)))
then
declare
Par_Specs : constant List_Id :=
Next (Par);
end loop;
end;
+
+ elsif Nkind (Decl) = N_Subprogram_Declaration
+ and then
+ Nkind (Specification (Decl)) = N_Function_Specification
+ and then
+ Nkind (Result_Definition (Specification (Decl)))
+ in N_Has_Entity
+ and then
+ Needs_Secondary_Stack
+ (Entity (Result_Definition (Specification (Decl))))
+ then
+ if Lock_Free_Given then
+ -- Message text is imprecise; "unconstrained" is
+ -- similar to "needs secondary stack" but not identical.
+ Error_Msg_N
+ ("unconstrained function result subtype not allowed "
+ & "when Lock_Free given",
+ Decl);
+ else
+ return False;
+ end if;
end if;
-- Examine private declarations after visible declarations
function Satisfies_Lock_Free_Requirements
(Sub_Body : Node_Id) return Boolean
is
- Is_Procedure : constant Boolean :=
- Ekind (Corresponding_Spec (Sub_Body)) =
- E_Procedure;
- -- Indicates if Sub_Body is a procedure body
-
Comp : Entity_Id := Empty;
-- Track the current component which the body references
-- Start of processing for Check_Node
begin
- if Is_Procedure then
- -- Allocators restricted
-
- if Kind = N_Allocator then
- if Lock_Free_Given then
- Error_Msg_N ("allocator not allowed", N);
- return Skip;
- end if;
+ -- Allocators restricted
- return Abandon;
+ if Kind = N_Allocator then
+ if Lock_Free_Given then
+ Error_Msg_N ("allocator not allowed", N);
+ return Skip;
+ end if;
- -- Aspects Address, Export and Import restricted
+ return Abandon;
- elsif Kind = N_Aspect_Specification then
- declare
- Asp_Name : constant Name_Id :=
- Chars (Identifier (N));
- Asp_Id : constant Aspect_Id :=
- Get_Aspect_Id (Asp_Name);
+ -- Aspects Address, Export and Import restricted
- begin
- if Asp_Id = Aspect_Address or else
- Asp_Id = Aspect_Export or else
- Asp_Id = Aspect_Import
- then
- Error_Msg_Name_1 := Asp_Name;
+ elsif Kind = N_Aspect_Specification then
+ declare
+ Asp_Name : constant Name_Id :=
+ Chars (Identifier (N));
+ Asp_Id : constant Aspect_Id :=
+ Get_Aspect_Id (Asp_Name);
- if Lock_Free_Given then
- Error_Msg_N ("aspect% not allowed", N);
- return Skip;
- end if;
+ begin
+ if Asp_Id = Aspect_Address or else
+ Asp_Id = Aspect_Export or else
+ Asp_Id = Aspect_Import
+ then
+ Error_Msg_Name_1 := Asp_Name;
- return Abandon;
+ if Lock_Free_Given then
+ Error_Msg_N ("aspect% not allowed", N);
+ return Skip;
end if;
- end;
- -- Address attribute definition clause restricted
+ return Abandon;
+ end if;
+ end;
- elsif Kind = N_Attribute_Definition_Clause
- and then Get_Attribute_Id (Chars (N)) =
- Attribute_Address
- then
- Error_Msg_Name_1 := Chars (N);
+ -- Address attribute definition clause restricted
- if Lock_Free_Given then
- if From_Aspect_Specification (N) then
- Error_Msg_N ("aspect% not allowed", N);
- else
- Error_Msg_N ("% clause not allowed", N);
- end if;
+ elsif Kind = N_Attribute_Definition_Clause
+ and then Get_Attribute_Id (Chars (N)) =
+ Attribute_Address
+ then
+ Error_Msg_Name_1 := Chars (N);
- return Skip;
+ if Lock_Free_Given then
+ if From_Aspect_Specification (N) then
+ Error_Msg_N ("aspect% not allowed", N);
+ else
+ Error_Msg_N ("% clause not allowed", N);
end if;
- return Abandon;
+ return Skip;
+ end if;
- -- Non-static Attribute references that don't denote a
- -- static function restricted.
+ return Abandon;
- elsif Kind = N_Attribute_Reference
- and then not Is_OK_Static_Expression (N)
- and then not Is_Static_Function (N)
- then
- if Lock_Free_Given then
- Error_Msg_N
- ("non-static attribute reference not allowed", N);
- return Skip;
- end if;
+ -- Non-static Attribute references that don't denote a
+ -- static function restricted.
- return Abandon;
+ elsif Kind = N_Attribute_Reference
+ and then not Is_OK_Static_Expression (N)
+ and then not Is_Static_Function (N)
+ then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("non-static attribute reference not allowed", N);
+ return Skip;
+ end if;
- -- Delay statements restricted
+ return Abandon;
- elsif Kind in N_Delay_Statement then
- if Lock_Free_Given then
- Error_Msg_N ("delay not allowed", N);
- return Skip;
- end if;
+ -- Delay statements restricted
- return Abandon;
+ elsif Kind in N_Delay_Statement then
+ if Lock_Free_Given then
+ Error_Msg_N ("delay not allowed", N);
+ return Skip;
+ end if;
- -- Dereferences of access values restricted
+ return Abandon;
- elsif Kind = N_Explicit_Dereference
- or else (Kind = N_Selected_Component
- and then Is_Access_Type (Etype (Prefix (N))))
- then
- if Lock_Free_Given then
- Error_Msg_N
- ("dereference of access value not allowed", N);
- return Skip;
- end if;
+ -- Dereferences of access values restricted
- return Abandon;
+ elsif Kind = N_Explicit_Dereference
+ or else (Kind = N_Selected_Component
+ and then Is_Access_Type (Etype (Prefix (N))))
+ then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("dereference of access value not allowed", N);
+ return Skip;
+ end if;
- -- Non-static function calls restricted
+ return Abandon;
- elsif Kind = N_Function_Call
- and then not Is_OK_Static_Expression (N)
- then
- if Lock_Free_Given then
- Error_Msg_N
- ("non-static function call not allowed", N);
- return Skip;
- end if;
+ -- Non-static function calls restricted
- return Abandon;
+ elsif Kind = N_Function_Call
+ and then not Is_OK_Static_Expression (N)
+ then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("non-static function call not allowed", N);
+ return Skip;
+ end if;
- -- Goto statements restricted
+ return Abandon;
- elsif Kind = N_Goto_Statement then
- if Lock_Free_Given then
- Error_Msg_N ("goto statement not allowed", N);
- return Skip;
- end if;
+ -- Goto statements restricted
- return Abandon;
+ elsif Kind = N_Goto_Statement then
+ if Lock_Free_Given then
+ Error_Msg_N ("goto statement not allowed", N);
+ return Skip;
+ end if;
- -- References
+ return Abandon;
- elsif Kind = N_Identifier
- and then Present (Entity (N))
- then
- declare
- Id : constant Entity_Id := Entity (N);
- Sub_Id : constant Entity_Id :=
- Corresponding_Spec (Sub_Body);
+ -- References
- begin
- -- Prohibit references to non-constant entities
- -- outside the protected subprogram scope.
-
- if Ekind (Id) in Assignable_Kind
- and then not
- Scope_Within_Or_Same (Scope (Id), Sub_Id)
- and then not
- Scope_Within_Or_Same
- (Scope (Id),
- Protected_Body_Subprogram (Sub_Id))
- then
- if Lock_Free_Given then
- Error_Msg_NE
- ("reference to global variable& not " &
- "allowed", N, Id);
- return Skip;
- end if;
+ elsif Kind = N_Identifier
+ and then Present (Entity (N))
+ then
+ declare
+ Id : constant Entity_Id := Entity (N);
+ Sub_Id : constant Entity_Id :=
+ Corresponding_Spec (Sub_Body);
- return Abandon;
+ begin
+ -- Prohibit references to non-constant entities
+ -- outside the protected subprogram scope.
+
+ if Is_Assignable (Id)
+ and then not
+ Scope_Within_Or_Same (Scope (Id), Sub_Id)
+ and then not
+ Scope_Within_Or_Same
+ (Scope (Id),
+ Protected_Body_Subprogram (Sub_Id))
+ then
+ if Lock_Free_Given then
+ Error_Msg_NE
+ ("reference to global variable& not allowed",
+ N, Id);
+ return Skip;
end if;
- end;
- -- Loop statements restricted
-
- elsif Kind = N_Loop_Statement then
- if Lock_Free_Given then
- Error_Msg_N ("loop not allowed", N);
- return Skip;
+ return Abandon;
end if;
+ end;
- return Abandon;
+ -- Loop statements restricted
- -- Pragmas Export and Import restricted
+ elsif Kind = N_Loop_Statement then
+ if Lock_Free_Given then
+ Error_Msg_N ("loop not allowed", N);
+ return Skip;
+ end if;
- elsif Kind = N_Pragma then
- declare
- Prag_Name : constant Name_Id :=
- Pragma_Name (N);
- Prag_Id : constant Pragma_Id :=
- Get_Pragma_Id (Prag_Name);
+ return Abandon;
- begin
- if Prag_Id = Pragma_Export
- or else Prag_Id = Pragma_Import
- then
- Error_Msg_Name_1 := Prag_Name;
+ -- Pragmas Export and Import restricted
- if Lock_Free_Given then
- if From_Aspect_Specification (N) then
- Error_Msg_N ("aspect% not allowed", N);
- else
- Error_Msg_N ("pragma% not allowed", N);
- end if;
+ elsif Kind = N_Pragma then
+ declare
+ Prag_Name : constant Name_Id :=
+ Pragma_Name (N);
+ Prag_Id : constant Pragma_Id :=
+ Get_Pragma_Id (Prag_Name);
+
+ begin
+ if Prag_Id = Pragma_Export
+ or else Prag_Id = Pragma_Import
+ then
+ Error_Msg_Name_1 := Prag_Name;
- return Skip;
+ if Lock_Free_Given then
+ if From_Aspect_Specification (N) then
+ Error_Msg_N ("aspect% not allowed", N);
+ else
+ Error_Msg_N ("pragma% not allowed", N);
end if;
- return Abandon;
+ return Skip;
end if;
- end;
- -- Procedure call statements restricted
-
- elsif Kind = N_Procedure_Call_Statement then
- if Lock_Free_Given then
- Error_Msg_N ("procedure call not allowed", N);
- return Skip;
+ return Abandon;
end if;
+ end;
- return Abandon;
+ -- Procedure call statements restricted
- -- Quantified expression restricted. Note that we have
- -- to check the original node as well, since at this
- -- stage, it may have been rewritten.
+ elsif Kind = N_Procedure_Call_Statement then
+ if Lock_Free_Given then
+ Error_Msg_N ("procedure call not allowed", N);
+ return Skip;
+ end if;
- elsif Kind = N_Quantified_Expression
- or else
- Nkind (Original_Node (N)) = N_Quantified_Expression
- then
- if Lock_Free_Given then
- Error_Msg_N
- ("quantified expression not allowed", N);
- return Skip;
- end if;
+ return Abandon;
- return Abandon;
+ -- Quantified expression restricted. Note that we have
+ -- to check the original node as well, since at this
+ -- stage, it may have been rewritten.
+
+ elsif Kind = N_Quantified_Expression
+ or else
+ Nkind (Original_Node (N)) = N_Quantified_Expression
+ then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("quantified expression not allowed", N);
+ return Skip;
end if;
+
+ return Abandon;
end if;
-- A protected subprogram (function or procedure) may
if Ekind (Id) = E_Component then
Comp_Id := Id;
- elsif Ekind_In (Id, E_Constant, E_Variable)
+ elsif Ekind (Id) in E_Constant | E_Variable
and then Present (Prival_Link (Id))
then
Comp_Id := Prival_Link (Id);
-- Start of processing for Satisfies_Lock_Free_Requirements
begin
+ if not Support_Atomic_Primitives_On_Target then
+ if Lock_Free_Given then
+ Error_Msg_N
+ ("Lock_Free aspect requires target support for "
+ & "atomic primitives", N);
+ end if;
+ return False;
+ end if;
+
+ -- Deal with case where Ceiling_Locking locking policy is
+ -- in effect.
+
+ if Locking_Policy = 'C' then
+ if Lock_Free_Given then
+ -- Explicit Lock_Free aspect spec overrides
+ -- Ceiling_Locking so we generate a warning.
+
+ Error_Msg_N
+ ("Lock_Free aspect specification overrides "
+ & "Ceiling_Locking locking policy??", N);
+ else
+ -- If Ceiling_Locking locking policy is in effect, then
+ -- Lock_Free can be explicitly specified but it is
+ -- never the default.
+
+ return False;
+ end if;
+ end if;
+
-- Get the number of errors detected by the compiler so far
if Lock_Free_Given then
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("abort statement is not allowed", N);
T_Name := First (Names (N));
while Present (T_Name) loop
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("accept statement is not allowed", N);
-- Entry name is initialized to Any_Id. It should get reset to the
-- matching entry entity. An error is signalled if it is not reset.
if Kind /= E_Block and then Kind /= E_Loop
and then not Is_Entry (Task_Nam)
then
- Error_Msg_N ("enclosing body of accept must be a task", N);
+ Error_Msg_N ("enclosing body of ACCEPT must be a task", N);
return;
end if;
end loop;
if Ekind (Etype (Task_Nam)) /= E_Task_Type then
- Error_Msg_N ("invalid context for accept statement", N);
+ Error_Msg_N ("invalid context for ACCEPT statement", N);
return;
end if;
end loop;
if Entry_Nam = Any_Id then
- Error_Msg_N ("no entry declaration matches accept statement", N);
+ Error_Msg_N ("no entry declaration matches ACCEPT statement", N);
return;
else
Set_Entity (Nam, Entry_Nam);
if Entry_Nam = Scope_Stack.Table (J).Entity then
Error_Msg_N
- ("duplicate accept statement for same entry (RM 9.5.2 (15))", N);
+ ("duplicate ACCEPT statement for same entry (RM 9.5.2 (15))", N);
-- Do not continue analysis of accept statement, to prevent
-- cascaded errors.
when N_Asynchronous_Select =>
Error_Msg_N
- ("accept statements are not allowed within an "
- & "asynchronous select inner to the enclosing task body",
+ ("ACCEPT statement not allowed within an "
+ & "asynchronous SELECT inner to the enclosing task body",
N);
exit;
end loop;
end;
- if Ekind (E) = E_Entry_Family then
+ if Ekind (Entry_Nam) = E_Entry_Family then
if No (Index) then
Error_Msg_N ("missing entry index in accept for entry family", N);
else
- Analyze_And_Resolve (Index, Entry_Index_Type (E));
- Apply_Range_Check (Index, Entry_Index_Type (E));
+ Analyze_And_Resolve (Index, Entry_Index_Type (Entry_Nam));
+ Apply_Scalar_Range_Check (Index, Entry_Index_Type (Entry_Nam));
end if;
elsif Present (Index) then
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("select statement is not allowed", N);
Check_Restriction (Max_Asynchronous_Select_Nesting, N);
Check_Restriction (No_Select_Statements, N);
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("select statement is not allowed", N);
Check_Restriction (No_Select_Statements, N);
-- Ada 2005 (AI-345): The trigger may be a dispatching call
Analyze_List (Pragmas_Before (N));
end if;
- if Nkind_In (Parent (N), N_Selective_Accept, N_Timed_Entry_Call) then
+ if Nkind (Parent (N)) in N_Selective_Accept | N_Timed_Entry_Call then
Expr := Expression (Delay_Statement (N));
-- Defer full analysis until the statement is expanded, to insure
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("delay statement is not allowed", N);
Check_Restriction (No_Relative_Delay, N);
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("delay statement is not allowed", N);
Check_Restriction (No_Delay, N);
Check_Potentially_Blocking_Operation (N);
Analyze_And_Resolve (E);
Analyze (Formals);
if Present (Entry_Index_Specification (Formals)) then
- Set_Ekind (Id, E_Entry_Family);
+ Mutate_Ekind (Id, E_Entry_Family);
else
- Set_Ekind (Id, E_Entry);
+ Mutate_Ekind (Id, E_Entry);
end if;
Set_Etype (Id, Standard_Void_Type);
E := First_Entity (P_Type);
while Present (E) loop
if Chars (E) = Chars (Id)
- and then (Ekind (E) = Ekind (Id))
+ and then Ekind (E) = Ekind (Id)
and then Type_Conformant (Id, E)
then
Entry_Name := E;
Set_Analyzed (Def, False);
-- Keep the original subtree to ensure a properly
- -- formed tree (e.g. for ASIS use).
+ -- formed tree.
Rewrite
(Discrete_Subtype_Definition (Index_Spec), Def);
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("entry call is not allowed", N);
if Present (Pragmas_Before (N)) then
Analyze_List (Pragmas_Before (N));
if Nkind (Call) = N_Explicit_Dereference then
Error_Msg_N
- ("entry call or dispatching primitive of interface required ", N);
+ ("entry call or dispatching primitive of interface required", N);
end if;
if Is_Non_Empty_List (Statements (N)) then
-- Case of no discrete subtype definition
if No (D_Sdef) then
- Set_Ekind (Def_Id, E_Entry);
+ Mutate_Ekind (Def_Id, E_Entry);
-- Processing for discrete subtype definition present
else
Enter_Name (Def_Id);
- Set_Ekind (Def_Id, E_Entry_Family);
+ Mutate_Ekind (Def_Id, E_Entry_Family);
Analyze (D_Sdef);
Make_Index (D_Sdef, N, Def_Id);
Make_Index (Def, N);
end if;
- Set_Ekind (Loop_Id, E_Loop);
+ Mutate_Ekind (Loop_Id, E_Loop);
Set_Scope (Loop_Id, Current_Scope);
Push_Scope (Loop_Id);
Enter_Name (Iden);
- Set_Ekind (Iden, E_Entry_Index_Parameter);
+ Mutate_Ekind (Iden, E_Entry_Index_Parameter);
Set_Etype (Iden, Etype (Def));
end Analyze_Entry_Index_Specification;
Freeze_Previous_Contracts (N);
Tasking_Used := True;
- Set_Ekind (Body_Id, E_Protected_Body);
+ Mutate_Ekind (Body_Id, E_Protected_Body);
Set_Etype (Body_Id, Standard_Void_Type);
Spec_Id := Find_Concurrent_Spec (Body_Id);
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("protected definition is not allowed", N);
Analyze_Declarations (Visible_Declarations (N));
- if Present (Private_Declarations (N))
- and then not Is_Empty_List (Private_Declarations (N))
- then
+ if not Is_Empty_List (Private_Declarations (N)) then
Last_Id := Last_Entity (Prot_Typ);
Analyze_Declarations (Private_Declarations (N));
Item_Id := First_Entity (Prot_Typ);
while Present (Item_Id) loop
- if Ekind_In (Item_Id, E_Function, E_Procedure) then
+ if Ekind (Item_Id) in E_Function | E_Procedure then
Set_Convention (Item_Id, Convention_Protected);
else
Propagate_Concurrent_Flags (Prot_Typ, Etype (Item_Id));
Set_Completion_Referenced (T);
end if;
- Set_Ekind (T, E_Protected_Type);
+ Mutate_Ekind (T, E_Protected_Type);
Set_Is_First_Subtype (T);
- Init_Size_Align (T);
+ Reinit_Size_Align (T);
Set_Etype (T, T);
Set_Has_Delayed_Freeze (T);
Set_Stored_Constraint (T, No_Elist);
+ -- Initialize type's primitive operations list, for possible use when
+ -- the extension of prefixed call notation for untagged types is enabled
+ -- (such as by use of -gnatX).
+
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+
-- Mark this type as a protected type for the sake of restrictions,
-- unless the protected type is declared in a private part of a package
-- of the runtime. With this exception, the Suspension_Object from
E := First_Entity (Current_Scope);
while Present (E) loop
if Ekind (E) = E_Void then
- Set_Ekind (E, E_Component);
- Init_Component_Location (E);
+ Mutate_Ekind (E, E_Component);
+ Reinit_Component_Location (E);
end if;
Next_Entity (E);
Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
+ -- Propagate predicate-related attributes from the private type to
+ -- the protected type.
+
+ Propagate_Predicate_Attributes (T, From_Typ => Def_Id);
+
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view.
---------------------
procedure Analyze_Requeue (N : Node_Id) is
+
+ procedure Check_Wrong_Attribute_In_Postconditions
+ (Entry_Id : Entity_Id;
+ Error_Node : Node_Id);
+ -- Check that the requeue target Entry_Id does not have an specific or
+ -- class-wide postcondition that references an Old or Index attribute.
+
+ ---------------------------------------------
+ -- Check_Wrong_Attribute_In_Postconditions --
+ ---------------------------------------------
+
+ procedure Check_Wrong_Attribute_In_Postconditions
+ (Entry_Id : Entity_Id;
+ Error_Node : Node_Id)
+ is
+ function Check_Node (N : Node_Id) return Traverse_Result;
+ -- Check that N is not a reference to attribute Index or Old; report
+ -- an error otherwise.
+
+ ----------------
+ -- Check_Node --
+ ----------------
+
+ function Check_Node (N : Node_Id) return Traverse_Result is
+ begin
+ if Nkind (N) = N_Attribute_Reference
+ and then Attribute_Name (N) in Name_Index
+ | Name_Old
+ then
+ Error_Msg_Name_1 := Attribute_Name (N);
+ Error_Msg_N
+ ("target of requeue must not have references to attribute % "
+ & "in postcondition",
+ Error_Node);
+ end if;
+
+ return OK;
+ end Check_Node;
+
+ procedure Check_Attr_Refs is new Traverse_Proc (Check_Node);
+
+ -- Local variables
+
+ Prag : Node_Id;
+ begin
+ Prag := Pre_Post_Conditions (Contract (Entry_Id));
+
+ while Present (Prag) loop
+ if Pragma_Name (Prag) = Name_Postcondition then
+ Check_Attr_Refs (First (Pragma_Argument_Associations (Prag)));
+ end if;
+
+ Prag := Next_Pragma (Prag);
+ end loop;
+ end Check_Wrong_Attribute_In_Postconditions;
+
+ -- Local variables
+
Count : Natural := 0;
Entry_Name : Node_Id := Name (N);
Entry_Id : Entity_Id;
Outer_Ent : Entity_Id;
Synch_Type : Entity_Id := Empty;
+ -- Start of processing for Analyze_Requeue
+
begin
-- Preserve relevant elaboration-related attributes of the context which
-- are no longer available or very expensive to recompute once analysis,
Warnings => True);
Tasking_Used := True;
- Check_SPARK_05_Restriction ("requeue statement is not allowed", N);
Check_Restriction (No_Requeue_Statements, N);
Check_Unreachable_Code (N);
Enclosing := Scope_Stack.Table (J).Entity;
exit when Is_Entry (Enclosing);
- if not Ekind_In (Enclosing, E_Block, E_Loop) then
+ if Ekind (Enclosing) not in E_Block | E_Loop then
Error_Msg_N ("requeue must appear within accept or entry body", N);
return;
end if;
-- entry body) unless it is a parameter of the innermost enclosing
-- accept statement (or entry body).
- if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
+ if Static_Accessibility_Level (Target_Obj, Zero_On_Dynamic_Level)
+ >= Scope_Depth (Outer_Ent)
and then
(not Is_Entity_Name (Target_Obj)
or else not Is_Formal (Entity (Target_Obj))
-- perform an unconditional goto so that any further
-- references will not occur anyway.
- if Ekind_In (Ent, E_Out_Parameter, E_In_Out_Parameter) then
+ if Ekind (Ent) in E_Out_Parameter | E_In_Out_Parameter then
Set_Never_Set_In_Source (Ent, False);
Set_Is_True_Constant (Ent, False);
end if;
("target protected object of requeue must be a variable", N);
end if;
+ -- Ada 2022 (AI12-0143): The requeue target shall not have an
+ -- applicable specific or class-wide postcondition which includes
+ -- an Old or Index attribute reference.
+
+ if Ekind (Entry_Id) = E_Entry_Family
+ and then Present (Contract (Entry_Id))
+ then
+ Check_Wrong_Attribute_In_Postconditions
+ (Entry_Id => Entry_Id,
+ Error_Node => Entry_Name);
+ end if;
+
-- A requeue statement is treated as a call for purposes of ABE checks
-- and diagnostics. Annotate the tree by creating a call marker in case
-- the requeue statement is transformed by expansion.
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("select statement is not allowed", N);
Check_Restriction (No_Select_Statements, N);
-- Loop to analyze alternatives
(Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
then
Error_Msg_N
- ("delay_until and delay_relative alternatives ", Alt);
+ ("delay_until and delay_relative alternatives", Alt);
Error_Msg_N
("\cannot appear in the same selective_wait", Alt);
end if;
if Entity (EDN1) = Ent then
Error_Msg_Sloc := Sloc (Stm1);
Error_Msg_N
- ("accept duplicates one on line#??", Stm);
+ ("ACCEPT duplicates one on line#??", Stm);
exit;
end if;
end if;
Check_Potentially_Blocking_Operation (N);
if Terminate_Present and Delay_Present then
- Error_Msg_N ("at most one of terminate or delay alternative", N);
+ Error_Msg_N ("at most one of TERMINATE or DELAY alternative", N);
elsif not Accept_Present then
Error_Msg_N
- ("select must contain at least one accept alternative", N);
+ ("SELECT must contain at least one ACCEPT alternative", N);
end if;
if Present (Else_Statements (N)) then
if Terminate_Present or Delay_Present then
- Error_Msg_N ("else part not allowed with other alternatives", N);
+ Error_Msg_N ("ELSE part not allowed with other alternatives", N);
end if;
Analyze_Statements (Else_Statements (N));
-- its own body.
Enter_Name (Typ);
- Set_Ekind (Typ, E_Protected_Type);
+ Mutate_Ekind (Typ, E_Protected_Type);
Set_Etype (Typ, Typ);
Set_Anonymous_Object (Typ, Obj_Id);
Enter_Name (Obj_Id);
- Set_Ekind (Obj_Id, E_Variable);
+ Mutate_Ekind (Obj_Id, E_Variable);
Set_Etype (Obj_Id, Typ);
Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Obj_Id);
-- in its own body.
Enter_Name (Typ);
- Set_Ekind (Typ, E_Task_Type);
+ Mutate_Ekind (Typ, E_Task_Type);
Set_Etype (Typ, Typ);
Set_Anonymous_Object (Typ, Obj_Id);
Enter_Name (Obj_Id);
- Set_Ekind (Obj_Id, E_Variable);
+ Mutate_Ekind (Obj_Id, E_Variable);
Set_Etype (Obj_Id, Typ);
Set_SPARK_Pragma (Obj_Id, SPARK_Mode_Pragma);
Set_SPARK_Pragma_Inherited (Obj_Id);
Tasking_Used := True;
Set_Scope (Body_Id, Current_Scope);
- Set_Ekind (Body_Id, E_Task_Body);
+ Mutate_Ekind (Body_Id, E_Task_Body);
Set_Etype (Body_Id, Standard_Void_Type);
Spec_Id := Find_Concurrent_Spec (Body_Id);
else
Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
end if;
+
+ -- The entity list of the current scope now includes entities in
+ -- the spec as well as the body. Their declarations will become
+ -- part of the statement sequence of the task body procedure that
+ -- is built during expansion. Indicate that aspect specifications
+ -- for these entities need not be rechecked. The guards on
+ -- Check_Aspect_At_End_Of_Declarations are not sufficient to
+ -- suppress these checks, because the declarations come from source.
+
+ declare
+ Priv : Entity_Id := First_Private_Entity (Spec_Id);
+
+ begin
+ while Present (Priv) loop
+ Set_Has_Delayed_Aspects (Priv, False);
+ Next_Entity (Priv);
+ end loop;
+ end;
end if;
-- Mark all handlers as not suitable for local raise optimization,
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("task definition is not allowed", N);
if Present (Visible_Declarations (N)) then
Analyze_Declarations (Visible_Declarations (N));
Set_Completion_Referenced (T);
else
- Set_Ekind (T, E_Task_Type);
+ Mutate_Ekind (T, E_Task_Type);
Set_Corresponding_Record_Type (T, Empty);
end if;
end if;
- Set_Ekind (T, E_Task_Type);
+ Mutate_Ekind (T, E_Task_Type);
Set_Is_First_Subtype (T, True);
Set_Has_Task (T, True);
- Init_Size_Align (T);
+ Reinit_Size_Align (T);
Set_Etype (T, T);
Set_Has_Delayed_Freeze (T, True);
Set_Stored_Constraint (T, No_Elist);
+ -- Initialize type's primitive operations list, for possible use when
+ -- the extension of prefixed call notation for untagged types is enabled
+ -- (such as by use of -gnatX).
+
+ Set_Direct_Primitive_Operations (T, New_Elmt_List);
+
-- Set the SPARK_Mode from the current context (may be overwritten later
-- with an explicit pragma).
Propagate_Invariant_Attributes (T, From_Typ => Def_Id);
+ -- Propagate predicate-related attributes from the private type to
+ -- task type.
+
+ Propagate_Predicate_Attributes (T, From_Typ => Def_Id);
+
-- Create corresponding record now, because some private dependents
-- may be subtypes of the partial view.
begin
Tasking_Used := True;
- Check_SPARK_05_Restriction ("select statement is not allowed", N);
Check_Restriction (No_Select_Statements, N);
-- Ada 2005 (AI-345): The trigger may be a dispatching call
begin
pragma Assert
- (Nkind_In (N, N_Protected_Type_Declaration, N_Task_Type_Declaration));
+ (Nkind (N) in N_Protected_Type_Declaration | N_Task_Type_Declaration);
if Present (Interface_List (N)) then
Set_Is_Tagged_Type (T);
-- The primitive operations of a tagged synchronized type are placed
-- on the Corresponding_Record for proper dispatching, but are
-- attached to the synchronized type itself when expansion is
- -- disabled, for ASIS use.
+ -- disabled.
Set_Direct_Primitive_Operations (T, New_Elmt_List);
Next (Iface);
end loop;
+
+ -- Check consistency of any nonoverridable aspects that are
+ -- inherited from multiple sources.
+
+ Check_Inherited_Nonoverridable_Aspects
+ (Inheritor => N,
+ Interface_List => Interface_List (N),
+ Parent_Type => Empty);
end if;
if not Has_Private_Declaration (T) then
elsif Nkind (Trigger) = N_Explicit_Dereference then
Error_Msg_N
- ("entry call or dispatching primitive of interface required ",
+ ("entry call or dispatching primitive of interface required",
Trigger);
end if;
end if;
git://gcc.gnu.org / gcc.git / blobdiff