-- If the expression is a completion, Prev is the entity whose
-- declaration is completed. Def_Id is needed to analyze the spec.
- -- Start of processing for Analyze_Expression_Function
-
begin
-- This is one of the occasions on which we transform the tree during
-- semantic analysis. If this is a completion, transform the expression
Set_Expression
(Original_Node (Subprogram_Spec (Def_Id)),
New_Copy_Tree (Expr));
+
+ -- Mark static expression functions as inlined, to ensure
+ -- that even calls with nonstatic actuals will be inlined.
+
+ Set_Has_Pragma_Inline (Def_Id);
+ Set_Is_Inlined (Def_Id);
end if;
end if;
end;
end if;
end Analyze_Expression_Function;
- ----------------------------------------
- -- Analyze_Extended_Return_Statement --
- ----------------------------------------
+ ---------------------------------------
+ -- Analyze_Extended_Return_Statement --
+ ---------------------------------------
procedure Analyze_Extended_Return_Statement (N : Node_Id) is
begin
elsif Kind = N_Function_Call
and then Is_Entity_Name (Name (Return_Expr))
- and then Ekind_In (Entity (Name (Return_Expr)), E_Function,
- E_Generic_Function)
+ and then Ekind (Entity (Name (Return_Expr))) in
+ E_Function | E_Generic_Function
and then No_Return (Entity (Name (Return_Expr)))
then
return;
------------------------------------------
procedure Check_Return_Construct_Accessibility (Return_Stmt : Node_Id) is
- Assoc : Node_Id;
- Agg : Node_Id := Empty;
- Discr : Entity_Id;
- Expr : Node_Id;
- Obj : Node_Id;
- Process_Exprs : Boolean := False;
- Return_Con : Node_Id;
+
+ function First_Selector (Assoc : Node_Id) return Node_Id;
+ -- Obtain the first selector or choice from a given association
+
+ --------------------
+ -- First_Selector --
+ --------------------
+
+ function First_Selector (Assoc : Node_Id) return Node_Id is
+ begin
+ if Nkind (Assoc) = N_Component_Association then
+ return First (Choices (Assoc));
+
+ elsif Nkind (Assoc) = N_Discriminant_Association then
+ return (First (Selector_Names (Assoc)));
+
+ else
+ raise Program_Error;
+ end if;
+ end First_Selector;
+
+ -- Local declarations
+
+ Assoc : Node_Id := Empty;
+ -- Assoc should perhaps be renamed and declared as a
+ -- Node_Or_Entity_Id since it encompasses not only component and
+ -- discriminant associations, but also discriminant components within
+ -- a type declaration or subtype indication ???
+
+ Assoc_Expr : Node_Id;
+ Assoc_Present : Boolean := False;
+
+ Unseen_Disc_Count : Nat := 0;
+ Seen_Discs : Elist_Id;
+ Disc : Entity_Id;
+ First_Disc : Entity_Id;
+
+ Obj_Decl : Node_Id;
+ Return_Con : Node_Id;
+ Unqual : Node_Id;
+
+ -- Start of processing for Check_Return_Construct_Accessibility
begin
-- Only perform checks on record types with access discriminants and
-- non-internally generated functions.
if not Is_Record_Type (R_Type)
- or else not Has_Discriminants (R_Type)
+ or else not Has_Anonymous_Access_Discriminant (R_Type)
or else not Comes_From_Source (Return_Stmt)
then
return;
-- We are only interested in return statements
- if not Nkind_In (Return_Stmt, N_Extended_Return_Statement,
- N_Simple_Return_Statement)
+ if Nkind (Return_Stmt) not in
+ N_Extended_Return_Statement | N_Simple_Return_Statement
then
return;
end if;
Return_Con := Original_Node (Return_Con);
else
- Return_Con := Return_Stmt;
+ Return_Con := Expression (Return_Stmt);
end if;
- -- We may need to check an aggregate or a subtype indication
- -- depending on how the discriminants were specified and whether
- -- we are looking at an extended return statement.
+ -- Obtain the accessibility levels of the expressions associated
+ -- with all anonymous access discriminants, then generate a
+ -- dynamic check or static error when relevant.
+
+ Unqual := Unqualify (Original_Node (Return_Con));
- if Nkind (Return_Con) = N_Object_Declaration
- and then Nkind (Object_Definition (Return_Con))
- = N_Subtype_Indication
+ -- Get the corresponding declaration based on the return object's
+ -- identifier.
+
+ if Nkind (Unqual) = N_Identifier
+ and then Nkind (Parent (Entity (Unqual)))
+ in N_Object_Declaration
+ | N_Object_Renaming_Declaration
then
- Assoc := Original_Node
- (First
- (Constraints
- (Constraint (Object_Definition (Return_Con)))));
+ Obj_Decl := Original_Node (Parent (Entity (Unqual)));
+
+ -- We were passed the object declaration directly, so use it
+
+ elsif Nkind (Unqual) in N_Object_Declaration
+ | N_Object_Renaming_Declaration
+ then
+ Obj_Decl := Unqual;
+
+ -- Otherwise, we are looking at something else
+
else
- -- Qualified expressions may be nested
+ Obj_Decl := Empty;
- Agg := Original_Node (Expression (Return_Con));
- while Nkind (Agg) = N_Qualified_Expression loop
- Agg := Original_Node (Expression (Agg));
- end loop;
+ end if;
+
+ -- Hop up object renamings when present
- -- If we are looking at an aggregate instead of a function call we
- -- can continue checking accessibility for the supplied
- -- discriminant associations.
+ if Present (Obj_Decl)
+ and then Nkind (Obj_Decl) = N_Object_Renaming_Declaration
+ then
+ while Nkind (Obj_Decl) = N_Object_Renaming_Declaration loop
+
+ if Nkind (Name (Obj_Decl)) not in N_Entity then
+ -- We may be looking at the expansion of iterators or
+ -- some other internally generated construct, so it is safe
+ -- to ignore checks ???
+
+ if not Comes_From_Source (Obj_Decl) then
+ return;
+ end if;
+
+ Obj_Decl := Original_Node
+ (Declaration_Node
+ (Ultimate_Prefix (Name (Obj_Decl))));
+
+ -- Move up to the next declaration based on the object's name
- if Nkind (Agg) = N_Aggregate then
- if Present (Expressions (Agg)) then
- Assoc := First (Expressions (Agg));
- Process_Exprs := True;
else
- Assoc := First (Component_Associations (Agg));
+ Obj_Decl := Original_Node
+ (Declaration_Node (Name (Obj_Decl)));
end if;
+ end loop;
+ end if;
+
+ -- Obtain the discriminant values from the return aggregate
- -- Otherwise the expression is not of interest ???
+ -- Do we cover extension aggregates correctly ???
+ if Nkind (Unqual) = N_Aggregate then
+ if Present (Expressions (Unqual)) then
+ Assoc := First (Expressions (Unqual));
else
- return;
+ Assoc := First (Component_Associations (Unqual));
end if;
- end if;
- -- Move through the discriminants checking the accessibility level
- -- of each co-extension's associated expression.
+ -- There is an object declaration for the return object
- Discr := First_Discriminant (R_Type);
- while Present (Discr) loop
- if Ekind (Etype (Discr)) = E_Anonymous_Access_Type then
+ elsif Present (Obj_Decl) then
+ -- When a subtype indication is present in an object declaration
+ -- it must contain the object's discriminants.
+
+ if Nkind (Object_Definition (Obj_Decl)) = N_Subtype_Indication then
+ Assoc := First
+ (Constraints
+ (Constraint
+ (Object_Definition (Obj_Decl))));
+
+ -- The object declaration contains an aggregate
+
+ elsif Present (Expression (Obj_Decl)) then
+
+ if Nkind (Unqualify (Expression (Obj_Decl))) = N_Aggregate then
+ -- Grab the first associated discriminant expresion
+
+ if Present
+ (Expressions (Unqualify (Expression (Obj_Decl))))
+ then
+ Assoc := First
+ (Expressions
+ (Unqualify (Expression (Obj_Decl))));
+ else
+ Assoc := First
+ (Component_Associations
+ (Unqualify (Expression (Obj_Decl))));
+ end if;
+
+ -- Otherwise, this is something else
- if Nkind (Assoc) = N_Attribute_Reference then
- Expr := Assoc;
- elsif Nkind_In (Assoc, N_Component_Association,
- N_Discriminant_Association)
- then
- Expr := Expression (Assoc);
else
- Expr := Empty;
+ return;
end if;
- -- This anonymous access discriminant has an associated
- -- expression which needs checking.
+ -- There are no supplied discriminants in the object declaration,
+ -- so get them from the type definition since they must be default
+ -- initialized.
- if Present (Expr)
- and then Nkind (Expr) = N_Attribute_Reference
- and then Attribute_Name (Expr) /= Name_Unrestricted_Access
- then
- -- Obtain the object to perform static checks on by moving
- -- up the prefixes in the expression taking into account
- -- named access types and renamed objects within the
- -- expression.
+ -- Do we handle constrained subtypes correctly ???
- Obj := Original_Node (Prefix (Expr));
- loop
- while Nkind_In (Obj, N_Explicit_Dereference,
- N_Indexed_Component,
- N_Selected_Component)
- loop
- -- When we encounter a named access type then we can
- -- ignore accessibility checks on the dereference.
+ elsif Nkind (Unqual) = N_Object_Declaration then
+ Assoc := First_Discriminant
+ (Etype (Object_Definition (Obj_Decl)));
- if Ekind (Etype (Original_Node (Prefix (Obj))))
- in E_Access_Type ..
- E_Access_Protected_Subprogram_Type
- then
- if Nkind (Obj) = N_Selected_Component then
- Obj := Selector_Name (Obj);
- else
- Obj := Original_Node (Prefix (Obj));
- end if;
- exit;
- end if;
+ else
+ Assoc := First_Discriminant (Etype (Unqual));
+ end if;
- Obj := Original_Node (Prefix (Obj));
- end loop;
+ -- When we are not looking at an aggregate or an identifier, return
+ -- since any other construct (like a function call) is not
+ -- applicable since checks will be performed on the side of the
+ -- callee.
- if Nkind (Obj) = N_Selected_Component then
- Obj := Selector_Name (Obj);
- end if;
+ else
+ return;
+ end if;
- -- Check for renamings
+ -- Obtain the discriminants so we know the actual type in case the
+ -- value of their associated expression gets implicitly converted.
- pragma Assert (Is_Entity_Name (Obj));
+ if No (Obj_Decl) then
+ pragma Assert (Nkind (Unqual) = N_Aggregate);
- if Present (Renamed_Object (Entity (Obj))) then
- Obj := Renamed_Object (Entity (Obj));
- else
- exit;
- end if;
- end loop;
+ Disc := First_Discriminant (Etype (Unqual));
- -- Do not check aliased formals or function calls. A
- -- run-time check may still be needed ???
+ else
+ Disc := First_Discriminant
+ (Etype (Defining_Identifier (Obj_Decl)));
+ end if;
- if Is_Formal (Entity (Obj))
- and then Is_Aliased (Entity (Obj))
- then
- null;
+ -- Preserve the first discriminant for checking named associations
- elsif Object_Access_Level (Obj) >
- Scope_Depth (Scope (Scope_Id))
- then
- Error_Msg_N
- ("access discriminant in return aggregate would "
- & "be a dangling reference", Obj);
+ First_Disc := Disc;
+
+ -- Count the number of discriminants for processing an aggregate
+ -- which includes an others.
+
+ Disc := First_Disc;
+ while Present (Disc) loop
+ Unseen_Disc_Count := Unseen_Disc_Count + 1;
+
+ Next_Discriminant (Disc);
+ end loop;
+
+ Seen_Discs := New_Elmt_List;
+
+ -- Loop through each of the discriminants and check each expression
+ -- associated with an anonymous access discriminant.
+
+ -- When named associations occur in the return aggregate then
+ -- discriminants can be in any order, so we need to ensure we do
+ -- not continue to loop when all discriminants have been seen.
+
+ Disc := First_Disc;
+ while Present (Assoc)
+ and then (Present (Disc) or else Assoc_Present)
+ and then Unseen_Disc_Count > 0
+ loop
+ -- Handle named associations by searching through the names of
+ -- the relevant discriminant components.
+
+ if Nkind (Assoc)
+ in N_Component_Association | N_Discriminant_Association
+ then
+ Assoc_Expr := Expression (Assoc);
+ Assoc_Present := True;
+
+ -- We currently don't handle box initialized discriminants,
+ -- however, since default initialized anonymous access
+ -- discriminants are a corner case, this is ok for now ???
+
+ if Nkind (Assoc) = N_Component_Association
+ and then Box_Present (Assoc)
+ then
+ Assoc_Present := False;
+
+ if Nkind (First_Selector (Assoc)) = N_Others_Choice then
+ Unseen_Disc_Count := 0;
end if;
+
+ -- When others is present we must identify a discriminant we
+ -- haven't already seen so as to get the appropriate type for
+ -- the static accessibility check.
+
+ -- This works because all components within an others clause
+ -- must have the same type.
+
+ elsif Nkind (First_Selector (Assoc)) = N_Others_Choice then
+
+ Disc := First_Disc;
+ Outer : while Present (Disc) loop
+ declare
+ Current_Seen_Disc : Elmt_Id;
+ begin
+ -- Move through the list of identified discriminants
+
+ Current_Seen_Disc := First_Elmt (Seen_Discs);
+ while Present (Current_Seen_Disc) loop
+ -- Exit the loop when we found a match
+
+ exit when
+ Chars (Node (Current_Seen_Disc)) = Chars (Disc);
+
+ Next_Elmt (Current_Seen_Disc);
+ end loop;
+
+ -- When we have exited the above loop without finding
+ -- a match then we know that Disc has not been seen.
+
+ exit Outer when No (Current_Seen_Disc);
+ end;
+
+ Next_Discriminant (Disc);
+ end loop Outer;
+
+ -- If we got to an others clause with a non-zero
+ -- discriminant count there must be a discriminant left to
+ -- check.
+
+ pragma Assert (Present (Disc));
+
+ -- Set the unseen discriminant count to zero because we know
+ -- an others clause sets all remaining components of an
+ -- aggregate.
+
+ Unseen_Disc_Count := 0;
+
+ -- Move through each of the selectors in the named association
+ -- and obtain a discriminant for accessibility checking if one
+ -- is referenced in the list. Also track which discriminants
+ -- are referenced for the purpose of handling an others clause.
+
+ else
+ declare
+ Assoc_Choice : Node_Id;
+ Curr_Disc : Node_Id;
+ begin
+
+ Disc := Empty;
+ Curr_Disc := First_Disc;
+ while Present (Curr_Disc) loop
+ -- Check each of the choices in the associations for a
+ -- match to the name of the current discriminant.
+
+ Assoc_Choice := First_Selector (Assoc);
+ while Present (Assoc_Choice) loop
+ -- When the name matches we track that we have seen
+ -- the discriminant, but instead of exiting the
+ -- loop we continue iterating to make sure all the
+ -- discriminants within the named association get
+ -- tracked.
+
+ if Chars (Assoc_Choice) = Chars (Curr_Disc) then
+ Append_Elmt (Curr_Disc, Seen_Discs);
+
+ Disc := Curr_Disc;
+ Unseen_Disc_Count := Unseen_Disc_Count - 1;
+ end if;
+
+ Next (Assoc_Choice);
+ end loop;
+
+ Next_Discriminant (Curr_Disc);
+ end loop;
+ end;
end if;
- end if;
- Next_Discriminant (Discr);
+ -- Unwrap the associated expression if we are looking at a default
+ -- initialized type declaration. In this case Assoc is not really
+ -- an association, but a component declaration. Should Assoc be
+ -- renamed in some way to be more clear ???
+
+ -- This occurs when the return object does not initialize
+ -- discriminant and instead relies on the type declaration for
+ -- their supplied values.
+
+ elsif Nkind (Assoc) in N_Entity
+ and then Ekind (Assoc) = E_Discriminant
+ then
+ Append_Elmt (Disc, Seen_Discs);
+
+ Assoc_Expr := Discriminant_Default_Value (Assoc);
+ Unseen_Disc_Count := Unseen_Disc_Count - 1;
+
+ -- Otherwise, there is nothing to do because Assoc is an
+ -- expression within the return aggregate itself.
- if not Is_List_Member (Assoc) then
- Assoc := Empty;
else
- Nlists.Next (Assoc);
+ Append_Elmt (Disc, Seen_Discs);
+
+ Assoc_Expr := Assoc;
+ Unseen_Disc_Count := Unseen_Disc_Count - 1;
end if;
- -- After aggregate expressions, examine component associations if
- -- present.
+ -- Check the accessibility level of the expression when the
+ -- discriminant is of an anonymous access type.
- if No (Assoc) then
- if Present (Agg)
- and then Process_Exprs
- and then Present (Component_Associations (Agg))
+ if Present (Assoc_Expr)
+ and then Present (Disc)
+ and then Ekind (Etype (Disc)) = E_Anonymous_Access_Type
+ then
+ -- Perform a static check first, if possible
+
+ if Static_Accessibility_Level
+ (Expr => Assoc_Expr,
+ Level => Zero_On_Dynamic_Level,
+ In_Return_Context => True)
+ > Scope_Depth (Scope (Scope_Id))
then
- Assoc := First (Component_Associations (Agg));
- Process_Exprs := False;
- else
+ Error_Msg_N
+ ("access discriminant in return object would be a dangling"
+ & " reference", Return_Stmt);
+
exit;
end if;
+
+ -- Otherwise, generate a dynamic check based on the extra
+ -- accessibility of the result.
+
+ if Present (Extra_Accessibility_Of_Result (Scope_Id)) then
+ Insert_Before_And_Analyze (Return_Stmt,
+ Make_Raise_Program_Error (Loc,
+ Condition =>
+ Make_Op_Gt (Loc,
+ Left_Opnd => Accessibility_Level
+ (Expr => Assoc_Expr,
+ Level => Dynamic_Level,
+ In_Return_Context => True),
+ Right_Opnd => Extra_Accessibility_Of_Result
+ (Scope_Id)),
+ Reason => PE_Accessibility_Check_Failed));
+ end if;
+ end if;
+
+ -- Iterate over the discriminants, except when we have encountered
+ -- a named association since the discriminant order becomes
+ -- irrelevant in that case.
+
+ if not Assoc_Present then
+ Next_Discriminant (Disc);
+ end if;
+
+ -- Iterate over associations
+
+ if not Is_List_Member (Assoc) then
+ exit;
+ else
+ Nlists.Next (Assoc);
end if;
end loop;
end Check_Return_Construct_Accessibility;
-- This early expansion is done only when the return statement is
-- not part of a handled sequence of statements.
- if Nkind_In (Expr, N_Aggregate,
- N_Extension_Aggregate)
+ if Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
and then Needs_Finalization (R_Type)
and then Nkind (Parent (N)) /= N_Handled_Sequence_Of_Statements
then
if Expander_Active
and then Serious_Errors_Detected = 0
and then Is_Access_Type (R_Type)
- and then not Nkind_In (Expr, N_Null, N_Raise_Expression)
+ and then Nkind (Expr) not in N_Null | N_Raise_Expression
and then Is_Interface (Designated_Type (R_Type))
and then Is_Progenitor (Designated_Type (R_Type),
Designated_Type (Etype (Expr)))
and then not Is_Constrained (R_Type)
and then Is_Build_In_Place_Function (Scope_Id)
and then Needs_BIP_Alloc_Form (Scope_Id)
- and then Nkind_In (Expr, N_Aggregate, N_Extension_Aggregate)
+ and then Nkind (Expr) in N_Aggregate | N_Extension_Aggregate
then
Preanalyze (Obj_Decl);
if (Ada_Version < Ada_2005 or else Debug_Flag_Dot_L)
and then Is_Limited_View (Etype (Scope_Id))
- and then Object_Access_Level (Expr) >
- Subprogram_Access_Level (Scope_Id)
+ and then Static_Accessibility_Level (Expr, Zero_On_Dynamic_Level)
+ > Subprogram_Access_Level (Scope_Id)
then
-- Suppress the message in a generic, where the rewriting
-- is irrelevant.
-- is just a string, as in (conjunction = "or"). In these cases the parser
-- generates this node, and the semantics does the disambiguation. Other
-- such case are actuals in an instantiation, the generic unit in an
- -- instantiation, and pragma arguments.
+ -- instantiation, pragma arguments, and aspect specifications.
procedure Analyze_Operator_Symbol (N : Node_Id) is
Par : constant Node_Id := Parent (N);
+ Maybe_Aspect_Spec : Node_Id := Par;
begin
+ if Nkind (Maybe_Aspect_Spec) /= N_Aspect_Specification then
+ -- deal with N_Aggregate nodes
+ Maybe_Aspect_Spec := Parent (Maybe_Aspect_Spec);
+ end if;
+
if (Nkind (Par) = N_Function_Call and then N = Name (Par))
or else Nkind (Par) = N_Function_Instantiation
or else (Nkind (Par) = N_Indexed_Component and then N = Prefix (Par))
or else Nkind (Par) = N_Subprogram_Renaming_Declaration
or else (Nkind (Par) = N_Attribute_Reference
and then Attribute_Name (Par) /= Name_Value)
+ or else (Nkind (Maybe_Aspect_Spec) = N_Aspect_Specification
+ and then Get_Aspect_Id (Maybe_Aspect_Spec)
+ -- include other aspects here ???
+ in Aspect_Stable_Properties | Aspect_Aggregate)
then
Find_Direct_Name (N);
-- Special processing for Elab_Spec, Elab_Body and Elab_Subp_Body calls
if Nkind (P) = N_Attribute_Reference
- and then Nam_In (Attribute_Name (P), Name_Elab_Spec,
- Name_Elab_Body,
- Name_Elab_Subp_Body)
+ and then Attribute_Name (P) in Name_Elab_Spec
+ | Name_Elab_Body
+ | Name_Elab_Subp_Body
then
if Present (Actuals) then
Error_Msg_N
and then Comes_From_Source (N)
then
Error_Msg_N ("missing explicit dereference in call", N);
+
+ elsif Ekind (Entity (P)) = E_Operator then
+ Error_Msg_Name_1 := Chars (P);
+ Error_Msg_N ("operator % cannot be used as a procedure", N);
end if;
Analyze_Call_And_Resolve;
-- function, the context will select the operation whose type is Void.
elsif Nkind (P) = N_Selected_Component
- and then Ekind_In (Entity (Selector_Name (P)), E_Entry,
- E_Function,
- E_Procedure)
+ and then Ekind (Entity (Selector_Name (P)))
+ in E_Entry | E_Function | E_Procedure
then
-- When front-end inlining is enabled, as with SPARK_Mode, a call
-- in prefix notation may still be missing its controlling argument,
else
Error_Msg_N ("invalid procedure or entry call", N);
+
+ -- Specialize the error message in the case where both a primitive
+ -- operation and a record component are visible at the same time.
+
+ if Nkind (P) = N_Selected_Component
+ and then Is_Entity_Name (Selector_Name (P))
+ then
+ declare
+ Sel : constant Entity_Id := Entity (Selector_Name (P));
+ begin
+ if Ekind (Sel) = E_Component
+ and then Present (Homonym (Sel))
+ and then Ekind (Homonym (Sel)) = E_Procedure
+ then
+ Error_Msg_NE ("\component & conflicts with"
+ & " homonym procedure (RM 4.1.3 (9.2/3))",
+ Selector_Name (P), Sel);
+ end if;
+ end;
+ end if;
end if;
<<Leave>>
------------------------------
procedure Analyze_Return_Statement (N : Node_Id) is
- pragma Assert (Nkind_In (N, N_Extended_Return_Statement,
- N_Simple_Return_Statement));
+ pragma Assert
+ (Nkind (N) in N_Extended_Return_Statement | N_Simple_Return_Statement);
Returns_Object : constant Boolean :=
Nkind (N) = N_Extended_Return_Statement
for J in reverse 0 .. Scope_Stack.Last loop
Result := Scope_Stack.Table (J).Entity;
- exit when not Ekind_In (Result, E_Block, E_Loop)
+ exit when Ekind (Result) not in E_Block | E_Loop
and then Chars (Result) /= Name_uPostconditions;
end loop;
-- implicitly-generated return that is placed at the end.
if No_Return (Scope_Id)
- and then Ekind_In (Kind, E_Procedure, E_Generic_Procedure)
+ and then Kind in E_Procedure | E_Generic_Procedure
and then Comes_From_Source (N)
then
Error_Msg_N
-- Check that functions return objects, and other things do not
- if Ekind_In (Kind, E_Function, E_Generic_Function) then
+ if Kind in E_Function | E_Generic_Function then
if not Returns_Object then
Error_Msg_N ("missing expression in return from function", N);
end if;
- elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then
+ elsif Kind in E_Procedure | E_Generic_Procedure then
if Returns_Object then
Error_Msg_N ("procedure cannot return value (use function)", N);
end if;
- elsif Ekind_In (Kind, E_Entry, E_Entry_Family) then
+ elsif Kind in E_Entry | E_Entry_Family then
if Returns_Object then
if Is_Protected_Type (Scope (Scope_Id)) then
Error_Msg_N ("entry body cannot return value", N);
Error_Msg_N ("illegal context for return statement", N);
end if;
- if Ekind_In (Kind, E_Function, E_Generic_Function) then
+ if Kind in E_Function | E_Generic_Function then
Analyze_Function_Return (N);
- elsif Ekind_In (Kind, E_Procedure, E_Generic_Procedure) then
+ elsif Kind in E_Procedure | E_Generic_Procedure then
Set_Return_Present (Scope_Id);
end if;
null;
elsif Nkind (Parent (N)) = N_Subprogram_Body
- or else Nkind_In (Parent (Parent (N)), N_Accept_Statement,
- N_Entry_Body)
+ or else Nkind (Parent (Parent (N))) in
+ N_Accept_Statement | N_Entry_Body
then
Error_Msg_NE
("invalid use of untagged incomplete type&",
Loc : constant Source_Ptr := Sloc (N);
Prev_Id : constant Entity_Id := Current_Entity_In_Scope (Body_Id);
+ Body_Nod : Node_Id := Empty;
+ Minimum_Acc_Objs : List_Id := No_List;
+
Conformant : Boolean;
Desig_View : Entity_Id := Empty;
Exch_Views : Elist_Id := No_Elist;
-- limited views with the non-limited ones. Return the list of changes
-- to be used to undo the transformation.
+ procedure Generate_Minimum_Accessibility
+ (Extra_Access : Entity_Id;
+ Related_Form : Entity_Id := Empty);
+ -- Generate a minimum accessibility object for a given extra
+ -- accessibility formal (Extra_Access) and its related formal if it
+ -- exists.
+
function Is_Private_Concurrent_Primitive
(Subp_Id : Entity_Id) return Boolean;
-- Determine whether subprogram Subp_Id is a primitive of a concurrent
-- Required to ensure that Expand_Call rewrites calls to this
-- function by calls to the built procedure.
- if Modify_Tree_For_C
+ if Transform_Function_Array
and then Nkind (Body_Spec) = N_Function_Specification
and then
- Rewritten_For_C (Defining_Entity (Specification (Subp_Decl)))
+ Rewritten_For_C (Defining_Entity (Specification (Subp_Decl)))
then
Set_Rewritten_For_C (Defining_Entity (Body_Spec));
Set_Corresponding_Procedure (Defining_Entity (Body_Spec),
-- the environment task is our effective master, so nothing
-- to mark.
- if Nkind_In
- (Par, N_Task_Body, N_Block_Statement, N_Subprogram_Body)
+ if Nkind (Par)
+ in N_Task_Body | N_Block_Statement | N_Subprogram_Body
then
Set_Is_Task_Master (Par, True);
exit;
-- Do not process subprogram bodies as they already use the non-
-- limited view of types.
- if not Ekind_In (Subp_Id, E_Function, E_Procedure) then
+ if Ekind (Subp_Id) not in E_Function | E_Procedure then
return No_Elist;
end if;
return Result;
end Exchange_Limited_Views;
+ ------------------------------------
+ -- Generate_Minimum_Accessibility --
+ ------------------------------------
+
+ procedure Generate_Minimum_Accessibility
+ (Extra_Access : Entity_Id;
+ Related_Form : Entity_Id := Empty)
+ is
+ Loc : constant Source_Ptr := Sloc (Body_Nod);
+ Form : Entity_Id;
+ Obj_Node : Node_Id;
+ begin
+ -- When no related formal exists then we are dealing with an
+ -- extra accessibility formal for a function result.
+
+ if No (Related_Form) then
+ Form := Extra_Access;
+ else
+ Form := Related_Form;
+ end if;
+
+ -- Create the minimum accessibility object
+
+ Obj_Node :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier =>
+ Make_Temporary
+ (Loc, 'A', Extra_Access),
+ Object_Definition => New_Occurrence_Of
+ (Standard_Natural, Loc),
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of
+ (Standard_Natural, Loc),
+ Attribute_Name => Name_Min,
+ Expressions => New_List (
+ Make_Integer_Literal (Loc,
+ Scope_Depth (Body_Id)),
+ New_Occurrence_Of
+ (Extra_Access, Loc))));
+
+ -- Add the new local object to the Minimum_Acc_Obj to
+ -- be later prepended to the subprogram's list of
+ -- declarations after we are sure all expansion is
+ -- done.
+
+ if Present (Minimum_Acc_Objs) then
+ Prepend (Obj_Node, Minimum_Acc_Objs);
+ else
+ Minimum_Acc_Objs := New_List (Obj_Node);
+ end if;
+
+ -- Register the object and analyze it
+
+ Set_Minimum_Accessibility
+ (Form, Defining_Identifier (Obj_Node));
+
+ Analyze (Obj_Node);
+ end Generate_Minimum_Accessibility;
+
-------------------------------------
-- Is_Private_Concurrent_Primitive --
-------------------------------------
if Is_Entity_Name (Node) and then Present (Entity (Node)) then
Mask_Type (Etype (Entity (Node)));
- if Ekind_In (Entity (Node), E_Component, E_Discriminant) then
+ if Ekind (Entity (Node)) in E_Component | E_Discriminant then
Mask_Type (Scope (Entity (Node)));
end if;
- elsif Nkind_In (Node, N_Aggregate, N_Null, N_Type_Conversion)
+ elsif Nkind (Node) in N_Aggregate | N_Null | N_Type_Conversion
and then Present (Etype (Node))
then
Mask_Type (Etype (Node));
-- Move relevant pragmas to the spec
- elsif Nam_In (Pragma_Name_Unmapped (Decl),
- Name_Depends,
- Name_Ghost,
- Name_Global,
- Name_Pre,
- Name_Precondition,
- Name_Post,
- Name_Refined_Depends,
- Name_Refined_Global,
- Name_Refined_Post,
- Name_Inline,
- Name_Pure_Function,
- Name_Volatile_Function)
+ elsif Pragma_Name_Unmapped (Decl) in Name_Depends
+ | Name_Ghost
+ | Name_Global
+ | Name_Pre
+ | Name_Precondition
+ | Name_Post
+ | Name_Refined_Depends
+ | Name_Refined_Global
+ | Name_Refined_Post
+ | Name_Inline
+ | Name_Pure_Function
+ | Name_Volatile_Function
then
Remove (Decl);
Insert_After (Insert_Nod, Decl);
-- expansion. As a result, we add an exception for this case.
elsif not Present (Overridden_Operation (Spec_Id))
- and then not (Nam_In (Chars (Spec_Id), Name_Adjust,
- Name_Finalize,
- Name_Initialize)
+ and then not (Chars (Spec_Id) in Name_Adjust
+ | Name_Finalize
+ | Name_Initialize
and then In_Instance)
then
Error_Msg_NE
-- Local variables
- Body_Nod : Node_Id := Empty;
- Minimum_Acc_Objs : List_Id := No_List;
-
Saved_GM : constant Ghost_Mode_Type := Ghost_Mode;
Saved_IGR : constant Node_Id := Ignored_Ghost_Region;
Saved_EA : constant Boolean := Expander_Active;
Build_Subprogram_Declaration;
-- If this is a function that returns a constrained array, and
- -- we are generating C code, create subprogram declaration
- -- to simplify subsequent C generation.
+ -- Transform_Function_Array is set, create subprogram
+ -- declaration to simplify e.g. subsequent C generation.
elsif No (Spec_Id)
- and then Modify_Tree_For_C
+ and then Transform_Function_Array
and then Nkind (Body_Spec) = N_Function_Specification
and then Is_Array_Type (Etype (Body_Id))
and then Is_Constrained (Etype (Body_Id))
Spec_Id := Build_Internal_Protected_Declaration (N);
end if;
- -- If we are generating C and this is a function returning a constrained
- -- array type for which we must create a procedure with an extra out
- -- parameter, build and analyze the body now. The procedure declaration
- -- has already been created. We reuse the source body of the function,
- -- because in an instance it may contain global references that cannot
- -- be reanalyzed. The source function itself is not used any further,
- -- so we mark it as having a completion. If the subprogram is a stub the
- -- transformation is done later, when the proper body is analyzed.
+ -- If Transform_Function_Array is set and this is a function returning a
+ -- constrained array type for which we must create a procedure with an
+ -- extra out parameter, build and analyze the body now. The procedure
+ -- declaration has already been created. We reuse the source body of the
+ -- function, because in an instance it may contain global references
+ -- that cannot be reanalyzed. The source function itself is not used any
+ -- further, so we mark it as having a completion. If the subprogram is a
+ -- stub the transformation is done later, when the proper body is
+ -- analyzed.
if Expander_Active
- and then Modify_Tree_For_C
+ and then Transform_Function_Array
and then Present (Spec_Id)
and then Ekind (Spec_Id) = E_Function
and then Nkind (N) /= N_Subprogram_Body_Stub
-- This method is used to supplement our "small integer model" for
-- accessibility-check generation (for more information see
- -- Dynamic_Accessibility_Level).
+ -- Accessibility_Level).
-- Because we allow accessibility values greater than our expected value
-- passing along the same extra accessibility formal as an actual
then
-- Generate the minimum accessibility level object
- -- A60b : natural := natural'min(1, paramL);
+ -- A60b : constant natural := natural'min(1, paramL);
- declare
- Loc : constant Source_Ptr := Sloc (Body_Nod);
- Obj_Node : constant Node_Id :=
- Make_Object_Declaration (Loc,
- Defining_Identifier =>
- Make_Temporary
- (Loc, 'A', Extra_Accessibility (Form)),
- Object_Definition => New_Occurrence_Of
- (Standard_Natural, Loc),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of
- (Standard_Natural, Loc),
- Attribute_Name => Name_Min,
- Expressions => New_List (
- Make_Integer_Literal (Loc,
- Object_Access_Level (Form)),
- New_Occurrence_Of
- (Extra_Accessibility (Form), Loc))));
- begin
- -- Add the new local object to the Minimum_Acc_Obj to
- -- be later prepended to the subprogram's list of
- -- declarations after we are sure all expansion is
- -- done.
+ Generate_Minimum_Accessibility
+ (Extra_Accessibility (Form), Form);
+ end if;
- if Present (Minimum_Acc_Objs) then
- Prepend (Obj_Node, Minimum_Acc_Objs);
- else
- Minimum_Acc_Objs := New_List (Obj_Node);
- end if;
+ Next_Formal (Form);
+ end loop;
- -- Register the object and analyze it
+ -- Generate the minimum accessibility level object for the
+ -- function's Extra_Accessibility_Of_Result.
- Set_Minimum_Accessibility
- (Form, Defining_Identifier (Obj_Node));
+ -- A31b : constant natural := natural'min (2, funcL);
- Analyze (Obj_Node);
- end;
- end if;
+ if Ekind (Body_Id) = E_Function
+ and then Present (Extra_Accessibility_Of_Result (Body_Id))
+ then
+ Generate_Minimum_Accessibility
+ (Extra_Accessibility_Of_Result (Body_Id));
- Next_Formal (Form);
- end loop;
+ -- Replace the Extra_Accessibility_Of_Result with the new
+ -- minimum accessibility object.
+
+ Set_Extra_Accessibility_Of_Result
+ (Body_Id, Minimum_Accessibility
+ (Extra_Accessibility_Of_Result (Body_Id)));
+ end if;
end if;
end;
end if;
-- Push_xxx_Error_Label to find the first real statement.
Stm := First (Statements (HSS));
- while Nkind_In (Stm, N_Call_Marker, N_Label)
- or else Nkind (Stm) in N_Push_xxx_Label
- loop
+ while Nkind (Stm) in N_Call_Marker | N_Label | N_Push_xxx_Label loop
Next (Stm);
end loop;
-- In case of primitives associated with abstract interface types
-- the check is applied later (see Analyze_Subprogram_Declaration).
- if not Nkind_In (Original_Node (Parent (N)),
- N_Abstract_Subprogram_Declaration,
- N_Formal_Abstract_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (Original_Node (Parent (N))) not in
+ N_Abstract_Subprogram_Declaration |
+ N_Formal_Abstract_Subprogram_Declaration |
+ N_Subprogram_Renaming_Declaration
then
if Is_Abstract_Type (Etype (Designator)) then
Error_Msg_N
-- in the message, and also provides the location for posting the
-- message in the absence of a specified Err_Loc location.
- function Conventions_Match
- (Id1 : Entity_Id;
- Id2 : Entity_Id) return Boolean;
- -- Determine whether the conventions of arbitrary entities Id1 and Id2
+ function Conventions_Match (Id1, Id2 : Entity_Id) return Boolean;
+ -- True if the conventions of entities Id1 and Id2 match.
+
+ function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean;
+ -- True if the null exclusions of two formals of anonymous access type
-- match.
-----------------------
-- the only way these may receive a convention is if they inherit
-- the convention of a related subprogram.
- if Ekind_In (Id1, E_Anonymous_Access_Subprogram_Type,
- E_Subprogram_Type)
+ if Ekind (Id1) in E_Anonymous_Access_Subprogram_Type
+ | E_Subprogram_Type
or else
- Ekind_In (Id2, E_Anonymous_Access_Subprogram_Type,
- E_Subprogram_Type)
+ Ekind (Id2) in E_Anonymous_Access_Subprogram_Type
+ | E_Subprogram_Type
then
return True;
end if;
end Conventions_Match;
+ ---------------------------
+ -- Null_Exclusions_Match --
+ ---------------------------
+
+ function Null_Exclusions_Match (F1, F2 : Entity_Id) return Boolean is
+ begin
+ if not Is_Anonymous_Access_Type (Etype (F1))
+ or else not Is_Anonymous_Access_Type (Etype (F2))
+ then
+ return True;
+ end if;
+
+ -- AI12-0289-1: Case of controlling access parameter; False if the
+ -- partial view is untagged, the full view is tagged, and no explicit
+ -- "not null". Note that at this point, we're processing the package
+ -- body, so private/full types have been swapped. The Sloc test below
+ -- is to detect the (legal) case where F1 comes after the full type
+ -- declaration. This part is disabled pre-2005, because "not null" is
+ -- not allowed on those language versions.
+
+ if Ada_Version >= Ada_2005
+ and then Is_Controlling_Formal (F1)
+ and then not Null_Exclusion_Present (Parent (F1))
+ and then not Null_Exclusion_Present (Parent (F2))
+ then
+ declare
+ D : constant Entity_Id := Directly_Designated_Type (Etype (F1));
+ Partial_View_Of_Desig : constant Entity_Id :=
+ Incomplete_Or_Partial_View (D);
+ begin
+ return No (Partial_View_Of_Desig)
+ or else Is_Tagged_Type (Partial_View_Of_Desig)
+ or else Sloc (D) < Sloc (F1);
+ end;
+
+ -- Not a controlling parameter, or one or both views have an explicit
+ -- "not null".
+
+ else
+ return Null_Exclusion_Present (Parent (F1)) =
+ Null_Exclusion_Present (Parent (F2));
+ end if;
+ end Null_Exclusions_Match;
+
-- Local Variables
Old_Type : constant Entity_Id := Etype (Old_Id);
-- Null exclusion must match
- if Null_Exclusion_Present (Parent (Old_Formal))
- /=
- Null_Exclusion_Present (Parent (New_Formal))
- then
- -- Only give error if both come from source. This should be
- -- investigated some time, since it should not be needed ???
-
- if Comes_From_Source (Old_Formal)
- and then
- Comes_From_Source (New_Formal)
- then
- Conformance_Error
- ("\null exclusion for& does not match", New_Formal);
+ if not Null_Exclusions_Match (Old_Formal, New_Formal) then
+ Conformance_Error
+ ("\null exclusion for& does not match", New_Formal);
- -- Mark error posted on the new formal to avoid duplicated
- -- complaint about types not matching.
+ -- Mark error posted on the new formal to avoid duplicated
+ -- complaint about types not matching.
- Set_Error_Posted (New_Formal);
- end if;
+ Set_Error_Posted (New_Formal);
end if;
end if;
if Ctype >= Mode_Conformant then
if Parameter_Mode (Old_Formal) /= Parameter_Mode (New_Formal) then
- if not Ekind_In (New_Id, E_Function, E_Procedure)
+ if Ekind (New_Id) not in E_Function | E_Procedure
or else not Is_Primitive_Wrapper (New_Id)
then
Conformance_Error ("\mode of & does not match!", New_Formal);
Decl := Unit_Declaration_Node (Subp);
end if;
- if Nkind_In (Decl, N_Subprogram_Body,
- N_Subprogram_Body_Stub,
- N_Subprogram_Declaration,
- N_Abstract_Subprogram_Declaration,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (Decl) in N_Subprogram_Body
+ | N_Subprogram_Body_Stub
+ | N_Subprogram_Declaration
+ | N_Abstract_Subprogram_Declaration
+ | N_Subprogram_Renaming_Declaration
then
Spec := Specification (Decl);
if Present (Overridden_Subp)
and then (not Is_Hidden (Overridden_Subp)
or else
- (Nam_In (Chars (Overridden_Subp), Name_Initialize,
- Name_Adjust,
- Name_Finalize)
+ (Chars (Overridden_Subp) in Name_Initialize
+ | Name_Adjust
+ | Name_Finalize
and then Present (Alias (Overridden_Subp))
and then (not Is_Hidden (Alias (Overridden_Subp))
or else In_Instance)))
-- Don't count exception junk
or else
- (Nkind_In (Last_Stm, N_Goto_Statement,
- N_Label,
- N_Object_Declaration)
+ (Nkind (Last_Stm) in
+ N_Goto_Statement | N_Label | N_Object_Declaration
and then Exception_Junk (Last_Stm))
- or else Nkind (Last_Stm) in N_Push_xxx_Label
- or else Nkind (Last_Stm) in N_Pop_xxx_Label
+ or else Nkind (Last_Stm) in N_Push_xxx_Label | N_Pop_xxx_Label
-- Inserted code, such as finalization calls, is irrelevant: we only
-- need to check original source.
function Is_Valid_Formal (F : Entity_Id) return Boolean is
begin
return
- Ekind_In (F, E_In_Out_Parameter, E_Out_Parameter)
+ Ekind (F) in E_In_Out_Parameter | E_Out_Parameter
or else
(Nkind (Parameter_Type (Parent (F))) = N_Access_Definition
and then not Constant_Present (Parameter_Type (Parent (F))));
-- Entries and procedures can override abstract or null interface
-- procedures.
- elsif Ekind_In (Def_Id, E_Entry, E_Procedure)
+ elsif Ekind (Def_Id) in E_Entry | E_Procedure
and then Ekind (Subp) = E_Procedure
and then Matches_Prefixed_View_Profile
(Parameter_Specifications (Parent (Def_Id)),
-- override, the first parameter of the overridden routine
-- must be of mode "out", "in out", or access-to-variable.
- if Ekind_In (Candidate, E_Entry, E_Procedure)
+ if Ekind (Candidate) in E_Entry | E_Procedure
and then Is_Protected_Type (Typ)
and then not Is_Valid_Formal (Formal)
then
-- or both could be access to protected subprograms.
Are_Anonymous_Access_To_Subprogram_Types :=
- Ekind_In (Type_1, E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type)
+ Ekind (Type_1) in E_Anonymous_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type
and then
- Ekind_In (Type_2, E_Anonymous_Access_Subprogram_Type,
- E_Anonymous_Access_Protected_Subprogram_Type);
+ Ekind (Type_2) in E_Anonymous_Access_Subprogram_Type
+ | E_Anonymous_Access_Protected_Subprogram_Type;
-- Test anonymous access type case. For this case, static subtype
-- matching is required for mode conformance (RM 6.3.1(15)). We check
-- to this are inherited operations from a parent type in which
-- case the derived type acts as their parent.
- if Nkind_In (Subp_Decl, N_Function_Specification,
- N_Procedure_Specification)
+ if Nkind (Subp_Decl) in N_Function_Specification
+ | N_Procedure_Specification
then
Subp_Decl := Parent (Subp_Decl);
end if;
("equality operator appears too late (Ada 2012)?y?", Eq_Op);
end if;
- -- No error detected
+ -- Finally check for AI12-0352: declaration of a user-defined primitive
+ -- equality operation for a record type T is illegal if it occurs after
+ -- a type has been derived from T.
else
- return;
+ Obj_Decl := Next (Parent (Typ));
+
+ while Present (Obj_Decl) and then Obj_Decl /= Decl loop
+ if Nkind (Obj_Decl) = N_Full_Type_Declaration
+ and then Etype (Defining_Identifier (Obj_Decl)) = Typ
+ then
+ Error_Msg_N
+ ("equality operator cannot appear after derivation", Eq_Op);
+ Error_Msg_NE
+ ("an equality operator for& cannot be declared after "
+ & "this point??",
+ Obj_Decl, Typ);
+ end if;
+
+ Next (Obj_Decl);
+ end loop;
end if;
end Check_Untagged_Equality;
-- conformant with it. That can occur in cases where an
-- actual type causes unrelated homographs in the instance.
- if Nkind_In (N, N_Subprogram_Body,
- N_Subprogram_Renaming_Declaration)
+ if Nkind (N) in N_Subprogram_Body
+ | N_Subprogram_Renaming_Declaration
and then Present (Homonym (E))
and then not Fully_Conformant (Designator, E)
then
function User_Defined_Numeric_Literal_Mismatch return Boolean is
E1_Is_User_Defined : constant Boolean :=
- not Nkind_In (Given_E1, N_Integer_Literal, N_Real_Literal);
+ Nkind (Given_E1) not in N_Integer_Literal | N_Real_Literal;
E2_Is_User_Defined : constant Boolean :=
- not Nkind_In (Given_E2, N_Integer_Literal, N_Real_Literal);
+ Nkind (Given_E2) not in N_Integer_Literal | N_Real_Literal;
+
begin
pragma Assert (E1_Is_User_Defined = E2_Is_User_Defined);
H := Homonym (H);
exit when not Present (H) or else Scope (H) /= Scope (S);
- if Nkind_In
- (Parent (H),
- N_Private_Extension_Declaration,
- N_Private_Type_Declaration)
+ if Nkind (Parent (H)) in
+ N_Private_Extension_Declaration |
+ N_Private_Type_Declaration
and then Defining_Identifier (Parent (H)) = Partial_View
then
return True;
and then not Is_Generic_Type (Formal_Type)
and then not Is_Class_Wide_Type (Formal_Type)
then
- if not Nkind_In
- (Parent (T), N_Access_Function_Definition,
- N_Access_Procedure_Definition)
+ if Nkind (Parent (T)) not in
+ N_Access_Function_Definition |
+ N_Access_Procedure_Definition
then
Append_Elmt (Current_Scope,
Private_Dependents (Base_Type (Formal_Type)));
end if;
end if;
- elsif not Nkind_In (Parent (T), N_Access_Function_Definition,
- N_Access_Procedure_Definition)
+ elsif Nkind (Parent (T)) not in N_Access_Function_Definition
+ | N_Access_Procedure_Definition
then
-- AI05-0151: Tagged incomplete types are allowed in all
-- formal parts. Untagged incomplete types are not allowed
then
null;
- elsif Nkind_In (Context, N_Accept_Statement,
- N_Accept_Alternative,
- N_Entry_Body)
+ elsif Nkind (Context) in N_Accept_Statement
+ | N_Accept_Alternative
+ | N_Entry_Body
or else (Nkind (Context) = N_Subprogram_Body
and then Comes_From_Source (Context))
then
-- these are not standard Ada legality rules.
if SPARK_Mode = On then
- if Ekind_In (Scope (Formal), E_Function, E_Generic_Function) then
+ if Ekind (Scope (Formal)) in E_Function | E_Generic_Function then
-- A function cannot have a parameter of mode IN OUT or OUT
-- (SPARK RM 6.1).
- if Ekind_In (Formal, E_In_Out_Parameter, E_Out_Parameter) then
+ if Ekind (Formal) in E_In_Out_Parameter | E_Out_Parameter then
Error_Msg_N
("function cannot have parameter of mode `OUT` or "
& "`IN OUT`", Formal);
end if;
end if;
+ -- Deal with aspects on formal parameters. Only Unreferenced is
+ -- supported for the time being.
+
+ if Has_Aspects (Param_Spec) then
+ declare
+ Aspect : Node_Id := First (Aspect_Specifications (Param_Spec));
+ begin
+ while Present (Aspect) loop
+ if Chars (Identifier (Aspect)) = Name_Unreferenced then
+ Set_Has_Pragma_Unreferenced (Formal);
+ else
+ Error_Msg_NE
+ ("unsupported aspect& on parameter",
+ Aspect, Identifier (Aspect));
+ end if;
+
+ Next (Aspect);
+ end loop;
+ end;
+ end if;
+
<<Continue>>
Next (Param_Spec);
end loop;
Set_Has_Out_Or_In_Out_Parameter (Id, True);
end if;
- if Ekind_In (Id, E_Function, E_Generic_Function) then
+ if Ekind (Id) in E_Function | E_Generic_Function then
-- [IN] OUT parameters allowed for functions in Ada 2012
-- Verify that user-defined operators have proper number of arguments
-- First case of operators which can only be unary
- if Nam_In (Id, Name_Op_Not, Name_Op_Abs) then
+ if Id in Name_Op_Not | Name_Op_Abs then
N_OK := (N = 1);
-- Case of operators which can be unary or binary
- elsif Nam_In (Id, Name_Op_Add, Name_Op_Subtract) then
+ elsif Id in Name_Op_Add | Name_Op_Subtract then
N_OK := (N in 1 .. 2);
-- All other operators can only be binary
projects / gcc.git / blobdiff