-- True otherwise. Proc is the entity for the procedure case and is used
-- in posting the warning message.
+ procedure Check_Untagged_Equality (Eq_Op : Entity_Id);
+ -- In Ada 2012, a primitive equality operator on an untagged record type
+ -- must appear before the type is frozen, and have the same visibility as
+ -- that of the type. This procedure checks that this rule is met, and
+ -- otherwise emits an error on the subprogram declaration and a warning
+ -- on the earlier freeze point if it is easy to locate.
+
procedure Enter_Overloaded_Entity (S : Entity_Id);
-- This procedure makes S, a new overloaded entity, into the first visible
-- entity with that name.
Subtype_Ind);
end if;
- if Is_Constrained (R_Type) then
+ -- AI05-103: for elementary types, subtypes must statically match
+
+ if Is_Constrained (R_Type)
+ or else Is_Access_Type (R_Type)
+ then
if not Subtypes_Statically_Match (R_Stm_Type, R_Type) then
Error_Msg_N
("subtype must statically match function result subtype",
Analyze (Explicit_Actual_Parameter (N));
end Analyze_Parameter_Association;
+ --------------------------------------
+ -- Analyze_Parameterized_Expression --
+ --------------------------------------
+
+ procedure Analyze_Parameterized_Expression (N : Node_Id) is
+ Loc : constant Source_Ptr := Sloc (N);
+ LocX : constant Source_Ptr := Sloc (Expression (N));
+
+ begin
+ -- This is one of the occasions on which we write things during semantic
+ -- analysis. Transform the parameterized expression into an equivalent
+ -- subprogram body, and then analyze that.
+
+ Rewrite (N,
+ Make_Subprogram_Body (Loc,
+ Specification => Specification (N),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (LocX,
+ Statements => New_List (
+ Make_Simple_Return_Statement (LocX,
+ Expression => Expression (N))))));
+ Analyze (N);
+ end Analyze_Parameterized_Expression;
+
----------------------------
-- Analyze_Procedure_Call --
----------------------------
if Present (Prag) then
if Present (Spec_Id) then
- if List_Containing (N) =
- List_Containing (Unit_Declaration_Node (Spec_Id))
- then
+ if In_Same_List (N, Unit_Declaration_Node (Spec_Id)) then
Analyze (Prag);
end if;
declare
Subp : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Chars (Body_Id));
+ Make_Defining_Identifier (Loc, Chars (Body_Id));
Decl : constant Node_Id :=
- Make_Subprogram_Declaration (Loc,
- Specification => New_Copy_Tree (Specification (N)));
+ Make_Subprogram_Declaration (Loc,
+ Specification =>
+ New_Copy_Tree (Specification (N)));
+
begin
Set_Defining_Unit_Name (Specification (Decl), Subp);
and then Present (Spec_Id)
and then No_Return (Spec_Id)
then
- Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
+ Check_Returns (HSS, 'P', Missing_Ret, Spec_Id);
end if;
end Check_Missing_Return;
-- Ada 2005 (AI-251): If the return type is abstract, verify that
-- the subprogram is abstract also. This does not apply to renaming
-- declarations, where abstractness is inherited.
+
-- In case of primitives associated with abstract interface types
-- the check is applied later (see Analyze_Subprogram_Declaration).
- if Is_Abstract_Type (Etype (Designator))
- and then not Is_Interface (Etype (Designator))
- and then Nkind (Parent (N)) /= N_Subprogram_Renaming_Declaration
- and then Nkind (Parent (N)) /=
- N_Abstract_Subprogram_Declaration
- and then
- (Nkind (Parent (N))) /= N_Formal_Abstract_Subprogram_Declaration
+ if not Nkind_In (Parent (N), N_Subprogram_Renaming_Declaration,
+ N_Abstract_Subprogram_Declaration,
+ N_Formal_Abstract_Subprogram_Declaration)
then
- Error_Msg_N
- ("function that returns abstract type must be abstract", N);
+ if Is_Abstract_Type (Etype (Designator))
+ and then not Is_Interface (Etype (Designator))
+ then
+ Error_Msg_N
+ ("function that returns abstract type must be abstract", N);
+
+ -- Ada 2012 (AI-0073): extend this test to subprograms with an
+ -- access result whose designated type is abstract.
+
+ elsif Nkind (Result_Definition (N)) = N_Access_Definition
+ and then
+ not Is_Class_Wide_Type (Designated_Type (Etype (Designator)))
+ and then Is_Abstract_Type (Designated_Type (Etype (Designator)))
+ and then Ada_Version >= Ada_12
+ then
+ Error_Msg_N ("function whose access result designates "
+ & "abstract type must be abstract", N);
+ end if;
end if;
end if;
Error_Msg_Name_1 := Chars (New_Id);
Error_Msg_Name_2 :=
Name_Ada + Convention_Id'Pos (Convention (New_Id));
-
Conformance_Error ("\prior declaration for% has convention %!");
else
Set_Error_Posted (New_Formal);
return;
end if;
+
+ -- 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);
+
+ -- Mark error posted on the new formal to avoid duplicated
+ -- complaint about types not matching.
+
+ Set_Error_Posted (New_Formal);
+ end if;
+ end if;
end if;
-- Ada 2005 (AI-423): Possible access [sub]type and itype match. This
or else
Is_Access_Constant (Etype (Old_Formal)) /=
Is_Access_Constant (Etype (New_Formal)))
+
+ -- Do not complain if error already posted on New_Formal. This
+ -- avoids some redundant error messages.
+
+ and then not Error_Posted (New_Formal)
then
-- It is allowed to omit the null-exclusion in case of stream
-- attribute subprograms. We recognize stream subprograms
Error_Msg_Name_2 := Get_Convention_Name (Convention (Op));
Error_Msg_Sloc := Sloc (Op);
- if Comes_From_Source (Op) then
+ if Comes_From_Source (Op) or else No (Alias (Op)) then
if not Is_Overriding_Operation (Op) then
Error_Msg_N ("\\primitive % defined #", Typ);
else
begin
-- In the case of functions with unconstrained result subtypes,
- -- add a 3-state formal indicating whether the return object is
- -- allocated by the caller (0), or should be allocated by the
- -- callee on the secondary stack (1) or in the global heap (2).
- -- For the moment we just use Natural for the type of this formal.
- -- Note that this formal isn't usually needed in the case where
- -- the result subtype is constrained, but it is needed when the
- -- function has a tagged result, because generally such functions
- -- can be called in a dispatching context and such calls must be
- -- handled like calls to a class-wide function.
+ -- add a 4-state formal indicating whether the return object is
+ -- allocated by the caller (1), or should be allocated by the
+ -- callee on the secondary stack (2), in the global heap (3), or
+ -- in a user-defined storage pool (4). For the moment we just use
+ -- Natural for the type of this formal. Note that this formal
+ -- isn't usually needed in the case where the result subtype is
+ -- constrained, but it is needed when the function has a tagged
+ -- result, because generally such functions can be called in a
+ -- dispatching context and such calls must be handled like calls
+ -- to a class-wide function.
if not Is_Constrained (Underlying_Type (Result_Subt))
or else Is_Tagged_Type (Underlying_Type (Result_Subt))
E, BIP_Formal_Suffix (BIP_Alloc_Form));
end if;
- -- In the case of functions whose result type has controlled
- -- parts, we have an extra formal of type
- -- System.Finalization_Implementation.Finalizable_Ptr_Ptr. That
- -- is, we are passing a pointer to a finalization list (which is
- -- itself a pointer). This extra formal is then passed along to
- -- Move_Final_List in case of successful completion of a return
- -- statement. We cannot pass an 'in out' parameter, because we
- -- need to update the finalization list during an abort-deferred
- -- region, rather than using copy-back after the function
- -- returns. This is true even if we are able to get away with
- -- having 'in out' parameters, which are normally illegal for
- -- functions. This formal is also needed when the function has
- -- a tagged result.
+ -- For functions whose result type has controlled parts, we have
+ -- an extra formal of type System.Finalization_Implementation.
+ -- Finalizable_Ptr_Ptr. That is, we are passing a pointer to a
+ -- finalization list (which is itself a pointer). This extra
+ -- formal is then passed along to Move_Final_List in case of
+ -- successful completion of a return statement. We cannot pass an
+ -- 'in out' parameter, because we need to update the finalization
+ -- list during an abort-deferred region, rather than using
+ -- copy-back after the function returns. This is true even if we
+ -- are able to get away with having 'in out' parameters, which are
+ -- normally illegal for functions. This formal is also needed when
+ -- the function has a tagged result.
if Needs_BIP_Final_List (E) then
Discard :=
end Enter_Overloaded_Entity;
-----------------------------
+ -- Check_Untagged_Equality --
+ -----------------------------
+
+ procedure Check_Untagged_Equality (Eq_Op : Entity_Id) is
+ Typ : constant Entity_Id := Etype (First_Formal (Eq_Op));
+ Decl : constant Node_Id := Unit_Declaration_Node (Eq_Op);
+ Obj_Decl : Node_Id;
+
+ begin
+ if Nkind (Decl) = N_Subprogram_Declaration
+ and then Is_Record_Type (Typ)
+ and then not Is_Tagged_Type (Typ)
+ then
+ if Is_Frozen (Typ) then
+ Error_Msg_NE
+ ("equality operator must be declared "
+ & "before type& is frozen", Eq_Op, Typ);
+
+ Obj_Decl := Next (Parent (Typ));
+ while Present (Obj_Decl)
+ and then Obj_Decl /= Decl
+ loop
+ if Nkind (Obj_Decl) = N_Object_Declaration
+ and then Etype (Defining_Identifier (Obj_Decl)) = Typ
+ then
+ Error_Msg_NE ("type& is frozen by declaration?",
+ Obj_Decl, Typ);
+ Error_Msg_N
+ ("\an equality operator cannot be declared after this "
+ & "point ('R'M 4.5.2 (9.8)) (Ada 2012))?", Obj_Decl);
+ exit;
+ end if;
+
+ Next (Obj_Decl);
+ end loop;
+
+ elsif not In_Same_List (Parent (Typ), Decl)
+ and then not Is_Limited_Type (Typ)
+ then
+ Error_Msg_N ("equality operator appears too late", Eq_Op);
+ end if;
+ end if;
+ end Check_Untagged_Equality;
+
+ -----------------------------
-- Find_Corresponding_Spec --
-----------------------------
-- that was created for an operation inherited by a null
-- extension, it may be overridden by a body without a previous
-- spec (one more reason why these should be shunned). In that
- -- case remove the generated body, because the current one is
- -- the explicit overriding.
+ -- case remove the generated body if present, because the
+ -- current one is the explicit overriding.
elsif Ekind (E) = E_Function
and then Ada_Version >= Ada_05
then
Set_Has_Completion (E, False);
- if Expander_Active then
+ if Expander_Active
+ and then Nkind (Parent (E)) = N_Function_Specification
+ then
Remove
(Unit_Declaration_Node
- (Corresponding_Body (Unit_Declaration_Node (E))));
+ (Corresponding_Body (Unit_Declaration_Node (E))));
+
return E;
- -- If expansion is disabled, the wrapper function has not
- -- been generated, and this is the standard case of a late
- -- body overriding an inherited operation.
+ -- If expansion is disabled, or if the wrapper function has
+ -- not been generated yet, this a late body overriding an
+ -- inherited operation, or it is an overriding by some other
+ -- declaration before the controlling result is frozen. In
+ -- either case this is a declaration of a new entity.
else
return Empty;
& "(RM 3.9.3(10))!", S);
elsif Ekind (S) = E_Function
- and then Is_Tagged_Type (T)
- and then T = Base_Type (Etype (S))
and then not Is_Overriding
then
- Error_Msg_N
- ("private function with tagged result must"
- & " override visible-part function", S);
- Error_Msg_N
- ("\move subprogram to the visible part"
- & " (RM 3.9.3(10))", S);
+ if Is_Tagged_Type (T)
+ and then T = Base_Type (Etype (S))
+ then
+ Error_Msg_N
+ ("private function with tagged result must"
+ & " override visible-part function", S);
+ Error_Msg_N
+ ("\move subprogram to the visible part"
+ & " (RM 3.9.3(10))", S);
+
+ -- AI05-0073: extend this test to the case of a function
+ -- with a controlling access result.
+
+ elsif Ekind (Etype (S)) = E_Anonymous_Access_Type
+ and then Is_Tagged_Type (Designated_Type (Etype (S)))
+ and then
+ not Is_Class_Wide_Type (Designated_Type (Etype (S)))
+ and then Ada_Version >= Ada_12
+ then
+ Error_Msg_N
+ ("private function with controlling access result "
+ & "must override visible-part function", S);
+ Error_Msg_N
+ ("\move subprogram to the visible part"
+ & " (RM 3.9.3(10))", S);
+ end if;
end if;
end if;
end Check_Private_Overriding;
E := Current_Entity_In_Scope (S);
+ -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
+ -- They are directly added to the list of primitive operations of
+ -- Derived_Type, unless this is a rederivation in the private part
+ -- of an operation that was already derived in the visible part of
+ -- the current package.
+
+ if Ada_Version >= Ada_05
+ and then Present (Derived_Type)
+ and then Present (Alias (S))
+ and then Is_Dispatching_Operation (Alias (S))
+ and then Present (Find_Dispatching_Type (Alias (S)))
+ and then Is_Interface (Find_Dispatching_Type (Alias (S)))
+ then
+ -- For private types, when the full-view is processed we propagate to
+ -- the full view the non-overridden entities whose attribute "alias"
+ -- references an interface primitive. These entities were added by
+ -- Derive_Subprograms to ensure that interface primitives are
+ -- covered.
+
+ -- Inside_Freeze_Actions is non zero when S corresponds with an
+ -- internal entity that links an interface primitive with its
+ -- covering primitive through attribute Interface_Alias (see
+ -- Add_Internal_Interface_Entities)
+
+ if Inside_Freezing_Actions = 0
+ and then Is_Package_Or_Generic_Package (Current_Scope)
+ and then In_Private_Part (Current_Scope)
+ and then Nkind (Parent (E)) = N_Private_Extension_Declaration
+ and then Nkind (Parent (S)) = N_Full_Type_Declaration
+ and then Full_View (Defining_Identifier (Parent (E)))
+ = Defining_Identifier (Parent (S))
+ and then Alias (E) = Alias (S)
+ then
+ Check_Operation_From_Private_View (S, E);
+ Set_Is_Dispatching_Operation (S);
+
+ -- Common case
+
+ else
+ Enter_Overloaded_Entity (S);
+ Check_Dispatching_Operation (S, Empty);
+ Check_For_Primitive_Subprogram (Is_Primitive_Subp);
+ end if;
+
+ return;
+ end if;
+
-- If there is no homonym then this is definitely not overriding
if No (E) then
-- E exists and is overloadable
else
- -- Ada 2005 (AI-251): Derivation of abstract interface primitives.
- -- They are directly added to the list of primitive operations of
- -- Derived_Type, unless this is a rederivation in the private part
- -- of an operation that was already derived in the visible part of
- -- the current package.
-
- if Ada_Version >= Ada_05
- and then Present (Derived_Type)
- and then Is_Dispatching_Operation (Alias (S))
- and then Present (Find_Dispatching_Type (Alias (S)))
- and then Is_Interface (Find_Dispatching_Type (Alias (S)))
- then
- if Type_Conformant (E, S)
- and then Is_Package_Or_Generic_Package (Current_Scope)
- and then In_Private_Part (Current_Scope)
- and then Parent (E) /= Parent (S)
- and then Alias (E) = Alias (S)
- then
- Check_Operation_From_Private_View (S, E);
- else
- goto Add_New_Entity;
- end if;
- end if;
-
Check_Synchronized_Overriding (S, Overridden_Subp);
-- Loop through E and its homonyms to determine if any of them is
E := Homonym (E);
end loop;
- <<Add_New_Entity>>
-
-- On exit, we know that S is a new entity
Enter_Overloaded_Entity (S);
then
Make_Inequality_Operator (S);
- -- In Ada 2012, a primitive equality operator on a record type
- -- must appear before the type is frozen, and have the same
- -- visibility as the type.
-
- declare
- Typ : constant Entity_Id := Etype (First_Formal (S));
- Decl : constant Node_Id := Unit_Declaration_Node (S);
-
- begin
- if Ada_Version >= Ada_12
- and then Nkind (Decl) = N_Subprogram_Declaration
- and then Is_Record_Type (Typ)
- then
- if Is_Frozen (Typ) then
- Error_Msg_NE
- ("equality operator must be declared "
- & "before type& is frozen", S, Typ);
-
- elsif List_Containing (Parent (Typ))
- /=
- List_Containing (Decl)
- and then not Is_Limited_Type (Typ)
- then
- Error_Msg_N
- ("equality operator appears too late", S);
- end if;
- end if;
- end;
+ if Ada_Version >= Ada_12 then
+ Check_Untagged_Equality (S);
+ end if;
end if;
end New_Overloaded_Entity;
OSDN Git Service
