Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'(
Attribute_Enum_Rep |
Attribute_Enum_Val => True,
+ Attribute_Index => True,
Attribute_Preelaborable_Initialization => True,
others => False);
-- sets the type of the attribute to the one specified by Str_Typ (e.g.
-- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image).
+ procedure Analyze_Index_Attribute
+ (Legal : out Boolean;
+ Spec_Id : out Entity_Id);
+ -- Processing for attribute 'Index. It checks that the attribute appears
+ -- in a pre/postcondition-like aspect or pragma associated with an entry
+ -- family. Flag Legal is set when the above criteria are met. Spec_Id
+ -- denotes the entity of the wrapper of the entry family or Empty if
+ -- the attribute is illegal.
+
procedure Bad_Attribute_For_Predicate;
-- Output error message for use of a predicate (First, Last, Range) not
-- allowed with a type that has predicates. If the type is a generic
end if;
end Analyze_Image_Attribute;
+ -----------------------------
+ -- Analyze_Index_Attribute --
+ -----------------------------
+
+ procedure Analyze_Index_Attribute
+ (Legal : out Boolean;
+ Spec_Id : out Entity_Id)
+ is
+ procedure Check_Placement_In_Check (Prag : Node_Id);
+ -- Verify that the attribute appears within pragma Check that mimics
+ -- a postcondition.
+
+ procedure Placement_Error;
+ pragma No_Return (Placement_Error);
+ -- Emit a general error when the attributes does not appear in a
+ -- precondition or postcondition aspect or pragma, and then raises
+ -- Bad_Attribute to avoid any further semantic processing.
+
+ ------------------------------
+ -- Check_Placement_In_Check --
+ ------------------------------
+
+ procedure Check_Placement_In_Check (Prag : Node_Id) is
+ Args : constant List_Id := Pragma_Argument_Associations (Prag);
+ Nam : constant Name_Id := Chars (Get_Pragma_Arg (First (Args)));
+
+ begin
+ -- The "Name" argument of pragma Check denotes a precondition or
+ -- postcondition.
+
+ if Nam in Name_Post
+ | Name_Postcondition
+ | Name_Pre
+ | Name_Precondition
+ | Name_Refined_Post
+ then
+ null;
+
+ -- Otherwise the placement of the attribute is illegal
+
+ else
+ Placement_Error;
+ end if;
+ end Check_Placement_In_Check;
+
+ ---------------------
+ -- Placement_Error --
+ ---------------------
+
+ procedure Placement_Error is
+ begin
+ Error_Attr
+ ("attribute % can only appear in pre- or postcondition", P);
+ end Placement_Error;
+
+ -- Local variables
+
+ Prag : Node_Id;
+ Prag_Nam : Name_Id;
+ Subp_Decl : Node_Id;
+
+ -- Start of processing for Analyze_Index_Attribute
+
+ begin
+ -- Assume that the attribute is illegal
+
+ Legal := False;
+ Spec_Id := Empty;
+
+ -- Skip processing during preanalysis of class-wide preconditions and
+ -- postconditions since at this stage the expression is not installed
+ -- yet on its definite context.
+
+ if Inside_Class_Condition_Preanalysis then
+ Legal := True;
+ Spec_Id := Current_Scope;
+ return;
+ end if;
+
+ -- Traverse the parent chain to find the aspect or pragma where the
+ -- attribute resides.
+
+ Prag := N;
+ while Present (Prag) loop
+ if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
+ exit;
+
+ -- Prevent the search from going too far
+
+ elsif Is_Body_Or_Package_Declaration (Prag) then
+ exit;
+ end if;
+
+ Prag := Parent (Prag);
+ end loop;
+
+ -- The attribute is allowed to appear only in precondition and
+ -- postcondition-like aspects or pragmas.
+
+ if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
+ if Nkind (Prag) = N_Aspect_Specification then
+ Prag_Nam := Chars (Identifier (Prag));
+ else
+ Prag_Nam := Pragma_Name (Prag);
+ end if;
+
+ if Prag_Nam = Name_Check then
+ Check_Placement_In_Check (Prag);
+
+ elsif Prag_Nam in Name_Post
+ | Name_Postcondition
+ | Name_Pre
+ | Name_Precondition
+ | Name_Refined_Post
+ then
+ null;
+
+ else
+ Placement_Error;
+ return;
+ end if;
+
+ -- Otherwise the placement of the attribute is illegal
+
+ else
+ Placement_Error;
+ return;
+ end if;
+
+ -- Find the related subprogram subject to the aspect or pragma
+
+ if Nkind (Prag) = N_Aspect_Specification then
+ Subp_Decl := Parent (Prag);
+ else
+ Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
+ end if;
+
+ -- The aspect or pragma where the attribute resides should be
+ -- associated with a subprogram declaration or a body since the
+ -- analysis of pre-/postconditions of entry and entry families is
+ -- performed in their wrapper subprogram. If this is not the case,
+ -- then the aspect or pragma is illegal and no further analysis is
+ -- required.
+
+ if Nkind (Subp_Decl) not in N_Subprogram_Body
+ | N_Subprogram_Declaration
+ then
+ return;
+ end if;
+
+ Spec_Id := Unique_Defining_Entity (Subp_Decl);
+
+ -- If we get here and Spec_Id denotes the entity of the entry wrapper
+ -- (or the postcondition procedure of the entry wrapper) then the
+ -- attribute is legal.
+
+ if Is_Entry_Wrapper (Spec_Id) then
+ Legal := True;
+
+ elsif Chars (Spec_Id) = Name_uPostconditions
+ and then Is_Entry_Wrapper (Scope (Spec_Id))
+ then
+ Spec_Id := Scope (Spec_Id);
+ Legal := True;
+
+ -- Otherwise the attribute is illegal and we return Empty
+
+ else
+ Spec_Id := Empty;
+ end if;
+ end Analyze_Index_Attribute;
+
---------------------------------
-- Bad_Attribute_For_Predicate --
---------------------------------
Check_Object_Reference (E1);
Set_Etype (N, Standard_Boolean);
+ -----------
+ -- Index --
+ -----------
+
+ when Attribute_Index => Index : declare
+ Ent : Entity_Id;
+ Legal : Boolean;
+ Spec_Id : Entity_Id;
+
+ begin
+ Check_E0;
+ Analyze_Index_Attribute (Legal, Spec_Id);
+
+ if not Legal or else No (Spec_Id) then
+ Error_Attr ("attribute % must apply to entry family", P);
+ return;
+ end if;
+
+ -- Legality checks
+
+ if Nkind (P) in N_Identifier | N_Expanded_Name then
+ Ent := Entity (P);
+
+ if Ekind (Ent) /= E_Entry_Family then
+ Error_Attr
+ ("attribute % must apply to entry family", P);
+
+ -- Analysis of pre/postconditions of an entry [family] occurs when
+ -- the conditions are relocated to the contract wrapper procedure
+ -- (see subprogram Build_Contract_Wrapper).
+
+ elsif Contract_Wrapper (Ent) /= Spec_Id then
+ Error_Attr
+ ("attribute % must apply to current entry family", P);
+ end if;
+
+ elsif Nkind (P) in N_Indexed_Component
+ | N_Selected_Component
+ then
+ Error_Attr
+ ("attribute % must apply to current entry family", P);
+
+ else
+ Error_Attr ("invalid entry family name", N);
+ end if;
+
+ Set_Etype (N, Entry_Index_Type (Ent));
+ end Index;
+
-----------------------
-- Has_Tagged_Values --
-----------------------
| Attribute_First_Bit
| Attribute_Img
| Attribute_Input
+ | Attribute_Index
| Attribute_Initialized
| Attribute_Last_Bit
| Attribute_Library_Level
when Attribute_Enabled =>
null;
+ -----------
+ -- Index --
+ -----------
+
+ when Attribute_Index =>
+ if Nkind (P) = N_Indexed_Component
+ and then Is_Entity_Name (Prefix (P))
+ then
+ declare
+ Indx : constant Node_Id := First (Expressions (P));
+ Fam : constant Entity_Id := Entity (Prefix (P));
+
+ begin
+ Resolve (Indx, Entry_Index_Type (Fam));
+ Apply_Scalar_Range_Check (Indx, Entry_Index_Type (Fam));
+ end;
+ end if;
+
----------------
-- Loop_Entry --
----------------
---------------------
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,
("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.
projects / thirdparty / gcc.git / commitdiff
