[Ada] Fix implementation issues with equality for untagged record types
This moves the implementation of AI12-0101 + AI05-0123 from the expander to the semantic analyzer and completes the implementation of AI12-0413, which are both binding interpretations in Ada 2012, fixing a few bugs in the process and removing a fair amount of duplicated code throughout. gcc/ada/ * einfo-utils.adb (Remove_Entity): Fix couple of oversights. * exp_ch3.adb (Is_User_Defined_Equality): Delete. (User_Defined_Eq): Call Get_User_Defined_Equality. (Make_Eq_Body): Likewise. (Predefined_Primitive_Eq_Body): Call Is_User_Defined_Equality. * exp_ch4.adb (Build_Eq_Call): Call Get_User_Defined_Equality. (Is_Equality): Delete. (User_Defined_Primitive_Equality_Op): Likewise. (Find_Aliased_Equality): Call Is_User_Defined_Equality. (Expand_N_Op_Eq): Call Underlying_Type unconditionally. Do not implement AI12-0101 + AI05-0123 here. (Expand_Set_Membership): Call Resolve_Membership_Equality. * exp_ch6.adb (Expand_Call_Helper): Remove obsolete code. * sem_aux.ads (Is_Record_Or_Limited_Type): Delete. * sem_aux.adb (Is_Record_Or_Limited_Type): Likewise. * sem_ch4.ads (Nondispatching_Call_To_Abstract_Operation): Declare. * sem_ch4.adb (Analyze_Call): Call Call_Abstract_Operation. (Analyze_Membership_Op): Call Resolve_Membership_Equality. (Nondispatching_Call_To_Abstract_Operation): New procedure. (Remove_Abstract_Operations): Call it. * sem_ch6.adb (Check_Untagged_Equality): Remove obsolete error and call Is_User_Defined_Equality. * sem_ch7.adb (Inspect_Untagged_Record_Completion): New procedure implementing AI12-0101 + AI05-0123. (Analyze_Package_Specification): Call it. (Declare_Inherited_Private_Subprograms): Minor tweak. (Uninstall_Declarations): Likewise. * sem_disp.adb (Check_Direct_Call): Adjust to new implementation of Is_User_Defined_Equality. * sem_res.ads (Resolve_Membership_Equality): Declare. * sem_res.adb (Resolve): Replace direct error handling with call to Nondispatching_Call_To_Abstract_Operation (Resolve_Call): Likewise. (Resolve_Equality_Op): Likewise. mplement AI12-0413. (Resolve_Membership_Equality): New procedure. (Resolve_Membership_Op): Call Get_User_Defined_Equality. * sem_util.ads (Get_User_Defined_Eq): Rename into... (Get_User_Defined_Equality): ...this. * sem_util.adb (Get_User_Defined_Eq): Rename into... (Get_User_Defined_Equality): ...this. Call Is_User_Defined_Equality. (Is_User_Defined_Equality): Also check the profile but remove tests on Comes_From_Source and Parent. * sinfo.ads (Generic_Parent_Type): Adjust field description. * uintp.ads (Ubool): Invoke user-defined equality in predicate.
This commit is contained in:
Eric Botcazou
Pierre-Marie de Rodat
parent
9a39b25f6f
commit
909ce3528c
17 changed files with 317 additions and 332 deletions
|
|
@ -2520,11 +2520,13 @@ package body Einfo.Utils is
|
|||
|
||||
elsif Id = First then
|
||||
Set_First_Entity (Scop, Next);
|
||||
Set_Prev_Entity (Next, Empty); -- Empty <-- First_Entity
|
||||
|
||||
-- The eliminated entity was the tail of the entity chain
|
||||
|
||||
elsif Id = Last then
|
||||
Set_Last_Entity (Scop, Prev);
|
||||
Set_Next_Entity (Prev, Empty); -- Last_Entity --> Empty
|
||||
|
||||
-- Otherwise the eliminated entity comes from the middle of the entity
|
||||
-- chain.
|
||||
|
|
|
|||
|
|
@ -271,9 +271,6 @@ package body Exp_Ch3 is
|
|||
-- in a case statement, recursively. This latter pattern may occur for the
|
||||
-- initialization procedure of an unchecked union.
|
||||
|
||||
function Is_User_Defined_Equality (Prim : Node_Id) return Boolean;
|
||||
-- Returns true if Prim is a user defined equality function
|
||||
|
||||
function Make_Eq_Body
|
||||
(Typ : Entity_Id;
|
||||
Eq_Name : Name_Id) return Node_Id;
|
||||
|
|
@ -4487,7 +4484,6 @@ package body Exp_Ch3 is
|
|||
Comp : Entity_Id;
|
||||
Decl : Node_Id;
|
||||
Op : Entity_Id;
|
||||
Prim : Elmt_Id;
|
||||
Eq_Op : Entity_Id;
|
||||
|
||||
function User_Defined_Eq (T : Entity_Id) return Entity_Id;
|
||||
|
|
@ -4506,7 +4502,7 @@ package body Exp_Ch3 is
|
|||
if Present (Op) then
|
||||
return Op;
|
||||
else
|
||||
return Get_User_Defined_Eq (T);
|
||||
return Get_User_Defined_Equality (T);
|
||||
end if;
|
||||
end User_Defined_Eq;
|
||||
|
||||
|
|
@ -4532,23 +4528,14 @@ package body Exp_Ch3 is
|
|||
-- If there is a user-defined equality for the type, we do not create
|
||||
-- the implicit one.
|
||||
|
||||
Prim := First_Elmt (Collect_Primitive_Operations (Typ));
|
||||
Eq_Op := Empty;
|
||||
while Present (Prim) loop
|
||||
if Chars (Node (Prim)) = Name_Op_Eq
|
||||
and then Comes_From_Source (Node (Prim))
|
||||
|
||||
-- Don't we also need to check formal types and return type as in
|
||||
-- User_Defined_Eq above???
|
||||
|
||||
then
|
||||
Eq_Op := Node (Prim);
|
||||
Eq_Op := Get_User_Defined_Equality (Typ);
|
||||
if Present (Eq_Op) then
|
||||
if Comes_From_Source (Eq_Op) then
|
||||
Build_Eq := False;
|
||||
exit;
|
||||
else
|
||||
Eq_Op := Empty;
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- If the type is derived, inherit the operation, if present, from the
|
||||
-- parent type. It may have been declared after the type derivation. If
|
||||
|
|
@ -4557,35 +4544,28 @@ package body Exp_Ch3 is
|
|||
-- flags. Ditto for inequality.
|
||||
|
||||
if No (Eq_Op) and then Is_Derived_Type (Typ) then
|
||||
Prim := First_Elmt (Collect_Primitive_Operations (Etype (Typ)));
|
||||
while Present (Prim) loop
|
||||
if Chars (Node (Prim)) = Name_Op_Eq then
|
||||
Copy_TSS (Node (Prim), Typ);
|
||||
Build_Eq := False;
|
||||
Eq_Op := Get_User_Defined_Equality (Etype (Typ));
|
||||
if Present (Eq_Op) then
|
||||
Copy_TSS (Eq_Op, Typ);
|
||||
Build_Eq := False;
|
||||
|
||||
declare
|
||||
Op : constant Entity_Id := User_Defined_Eq (Typ);
|
||||
Eq_Op : constant Entity_Id := Node (Prim);
|
||||
NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
|
||||
declare
|
||||
Op : constant Entity_Id := User_Defined_Eq (Typ);
|
||||
NE_Op : constant Entity_Id := Next_Entity (Eq_Op);
|
||||
|
||||
begin
|
||||
if Present (Op) then
|
||||
Set_Alias (Op, Eq_Op);
|
||||
begin
|
||||
if Present (Op) then
|
||||
Set_Alias (Op, Eq_Op);
|
||||
Set_Is_Abstract_Subprogram
|
||||
(Op, Is_Abstract_Subprogram (Eq_Op));
|
||||
|
||||
if Chars (Next_Entity (Op)) = Name_Op_Ne then
|
||||
Set_Is_Abstract_Subprogram
|
||||
(Op, Is_Abstract_Subprogram (Eq_Op));
|
||||
|
||||
if Chars (Next_Entity (Op)) = Name_Op_Ne then
|
||||
Set_Is_Abstract_Subprogram
|
||||
(Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
|
||||
end if;
|
||||
(Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
|
||||
end if;
|
||||
end;
|
||||
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim);
|
||||
end loop;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- If not inherited and not user-defined, build body as for a type with
|
||||
|
|
@ -9828,18 +9808,6 @@ package body Exp_Ch3 is
|
|||
return True;
|
||||
end Is_Null_Statement_List;
|
||||
|
||||
------------------------------
|
||||
-- Is_User_Defined_Equality --
|
||||
------------------------------
|
||||
|
||||
function Is_User_Defined_Equality (Prim : Node_Id) return Boolean is
|
||||
begin
|
||||
return Chars (Prim) = Name_Op_Eq
|
||||
and then Etype (First_Formal (Prim)) =
|
||||
Etype (Next_Formal (First_Formal (Prim)))
|
||||
and then Base_Type (Etype (Prim)) = Standard_Boolean;
|
||||
end Is_User_Defined_Equality;
|
||||
|
||||
----------------------------------------
|
||||
-- Make_Controlling_Function_Wrappers --
|
||||
----------------------------------------
|
||||
|
|
@ -11212,15 +11180,8 @@ package body Exp_Ch3 is
|
|||
|
||||
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
|
||||
while Present (Prim) loop
|
||||
if Chars (Node (Prim)) = Name_Op_Eq
|
||||
if Is_User_Defined_Equality (Node (Prim))
|
||||
and then not Is_Internal (Node (Prim))
|
||||
|
||||
-- The predefined equality primitive must have exactly two
|
||||
-- formals whose type is this tagged type.
|
||||
|
||||
and then Number_Formals (Node (Prim)) = 2
|
||||
and then Etype (First_Formal (Node (Prim))) = Tag_Typ
|
||||
and then Etype (Last_Formal (Node (Prim))) = Tag_Typ
|
||||
then
|
||||
Eq_Needed := False;
|
||||
Eq_Name := No_Name;
|
||||
|
|
@ -11236,7 +11197,7 @@ package body Exp_Ch3 is
|
|||
|
||||
Prim := First_Elmt (Primitive_Operations (Tag_Typ));
|
||||
while Present (Prim) loop
|
||||
if Chars (Node (Prim)) = Name_Op_Eq
|
||||
if Is_User_Defined_Equality (Node (Prim))
|
||||
and then Is_Internal (Node (Prim))
|
||||
then
|
||||
Eq_Needed := True;
|
||||
|
|
|
|||
|
|
@ -425,36 +425,21 @@ package body Exp_Ch4 is
|
|||
Lhs : Node_Id;
|
||||
Rhs : Node_Id) return Node_Id
|
||||
is
|
||||
Prim : Node_Id;
|
||||
Prim_E : Elmt_Id;
|
||||
Eq : constant Entity_Id := Get_User_Defined_Equality (Typ);
|
||||
|
||||
begin
|
||||
Prim_E := First_Elmt (Collect_Primitive_Operations (Typ));
|
||||
while Present (Prim_E) loop
|
||||
Prim := Node (Prim_E);
|
||||
if Present (Eq) then
|
||||
if Is_Abstract_Subprogram (Eq) then
|
||||
return Make_Raise_Program_Error (Loc,
|
||||
Reason => PE_Explicit_Raise);
|
||||
|
||||
-- Locate primitive equality with the right signature
|
||||
|
||||
if Chars (Prim) = Name_Op_Eq
|
||||
and then Etype (First_Formal (Prim)) =
|
||||
Etype (Next_Formal (First_Formal (Prim)))
|
||||
and then Etype (Prim) = Standard_Boolean
|
||||
then
|
||||
if Is_Abstract_Subprogram (Prim) then
|
||||
return
|
||||
Make_Raise_Program_Error (Loc,
|
||||
Reason => PE_Explicit_Raise);
|
||||
|
||||
else
|
||||
return
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Prim, Loc),
|
||||
Parameter_Associations => New_List (Lhs, Rhs));
|
||||
end if;
|
||||
else
|
||||
return
|
||||
Make_Function_Call (Loc,
|
||||
Name => New_Occurrence_Of (Eq, Loc),
|
||||
Parameter_Associations => New_List (Lhs, Rhs));
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim_E);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
-- If not found, predefined operation will be used
|
||||
|
||||
|
|
@ -7817,21 +7802,10 @@ package body Exp_Ch4 is
|
|||
-- build and analyze call, adding conversions if the operation is
|
||||
-- inherited.
|
||||
|
||||
function Is_Equality (Subp : Entity_Id;
|
||||
Typ : Entity_Id := Empty) return Boolean;
|
||||
-- Determine whether arbitrary Entity_Id denotes a function with the
|
||||
-- right name and profile for an equality op, specifically for the
|
||||
-- base type Typ if Typ is nonempty.
|
||||
|
||||
function Find_Equality (Prims : Elist_Id) return Entity_Id;
|
||||
-- Find a primitive equality function within primitive operation list
|
||||
-- Prims.
|
||||
|
||||
function User_Defined_Primitive_Equality_Op
|
||||
(Typ : Entity_Id) return Entity_Id;
|
||||
-- Find a user-defined primitive equality function for a given untagged
|
||||
-- record type, ignoring visibility. Return Empty if no such op found.
|
||||
|
||||
function Has_Unconstrained_UU_Component (Typ : Entity_Id) return Boolean;
|
||||
-- Determines whether a type has a subcomponent of an unconstrained
|
||||
-- Unchecked_Union subtype. Typ is a record type.
|
||||
|
|
@ -8080,43 +8054,6 @@ package body Exp_Ch4 is
|
|||
Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks);
|
||||
end Build_Equality_Call;
|
||||
|
||||
-----------------
|
||||
-- Is_Equality --
|
||||
-----------------
|
||||
|
||||
function Is_Equality (Subp : Entity_Id;
|
||||
Typ : Entity_Id := Empty) return Boolean is
|
||||
Formal_1 : Entity_Id;
|
||||
Formal_2 : Entity_Id;
|
||||
begin
|
||||
-- The equality function carries name "=", returns Boolean, and has
|
||||
-- exactly two formal parameters of an identical type.
|
||||
|
||||
if Ekind (Subp) = E_Function
|
||||
and then Chars (Subp) = Name_Op_Eq
|
||||
and then Base_Type (Etype (Subp)) = Standard_Boolean
|
||||
then
|
||||
Formal_1 := First_Formal (Subp);
|
||||
Formal_2 := Empty;
|
||||
|
||||
if Present (Formal_1) then
|
||||
Formal_2 := Next_Formal (Formal_1);
|
||||
end if;
|
||||
|
||||
return
|
||||
Present (Formal_1)
|
||||
and then Present (Formal_2)
|
||||
and then No (Next_Formal (Formal_2))
|
||||
and then Base_Type (Etype (Formal_1)) =
|
||||
Base_Type (Etype (Formal_2))
|
||||
and then
|
||||
(not Present (Typ)
|
||||
or else Implementation_Base_Type (Etype (Formal_1)) = Typ);
|
||||
end if;
|
||||
|
||||
return False;
|
||||
end Is_Equality;
|
||||
|
||||
-------------------
|
||||
-- Find_Equality --
|
||||
-------------------
|
||||
|
|
@ -8139,7 +8076,7 @@ package body Exp_Ch4 is
|
|||
|
||||
Candid := Prim;
|
||||
while Present (Candid) loop
|
||||
if Is_Equality (Candid) then
|
||||
if Is_User_Defined_Equality (Candid) then
|
||||
return Candid;
|
||||
end if;
|
||||
|
||||
|
|
@ -8178,43 +8115,6 @@ package body Exp_Ch4 is
|
|||
return Eq_Prim;
|
||||
end Find_Equality;
|
||||
|
||||
----------------------------------------
|
||||
-- User_Defined_Primitive_Equality_Op --
|
||||
----------------------------------------
|
||||
|
||||
function User_Defined_Primitive_Equality_Op
|
||||
(Typ : Entity_Id) return Entity_Id
|
||||
is
|
||||
Enclosing_Scope : constant Entity_Id := Scope (Typ);
|
||||
E : Entity_Id;
|
||||
begin
|
||||
for Private_Entities in Boolean loop
|
||||
if Private_Entities then
|
||||
if Ekind (Enclosing_Scope) /= E_Package then
|
||||
exit;
|
||||
end if;
|
||||
E := First_Private_Entity (Enclosing_Scope);
|
||||
|
||||
else
|
||||
E := First_Entity (Enclosing_Scope);
|
||||
end if;
|
||||
|
||||
while Present (E) loop
|
||||
if Is_Equality (E, Typ) then
|
||||
return E;
|
||||
end if;
|
||||
Next_Entity (E);
|
||||
end loop;
|
||||
end loop;
|
||||
|
||||
if Is_Derived_Type (Typ) then
|
||||
return User_Defined_Primitive_Equality_Op
|
||||
(Implementation_Base_Type (Etype (Typ)));
|
||||
end if;
|
||||
|
||||
return Empty;
|
||||
end User_Defined_Primitive_Equality_Op;
|
||||
|
||||
------------------------------------
|
||||
-- Has_Unconstrained_UU_Component --
|
||||
------------------------------------
|
||||
|
|
@ -8358,14 +8258,7 @@ package body Exp_Ch4 is
|
|||
|
||||
-- Deal with private types
|
||||
|
||||
Typl := A_Typ;
|
||||
|
||||
if Ekind (Typl) = E_Private_Type then
|
||||
Typl := Underlying_Type (Typl);
|
||||
|
||||
elsif Ekind (Typl) = E_Private_Subtype then
|
||||
Typl := Underlying_Type (Base_Type (Typl));
|
||||
end if;
|
||||
Typl := Underlying_Type (A_Typ);
|
||||
|
||||
-- It may happen in error situations that the underlying type is not
|
||||
-- set. The error will be detected later, here we just defend the
|
||||
|
|
@ -8529,15 +8422,6 @@ package body Exp_Ch4 is
|
|||
(Find_Equality (Primitive_Operations (Typl)));
|
||||
end if;
|
||||
|
||||
-- See AI12-0101 (which only removes a legality rule) and then
|
||||
-- AI05-0123 (which then applies in the previously illegal case).
|
||||
-- AI12-0101 is a binding interpretation.
|
||||
|
||||
elsif Ada_Version >= Ada_2012
|
||||
and then Present (User_Defined_Primitive_Equality_Op (Typl))
|
||||
then
|
||||
Build_Equality_Call (User_Defined_Primitive_Equality_Op (Typl));
|
||||
|
||||
-- Ada 2005 (AI-216): Program_Error is raised when evaluating the
|
||||
-- predefined equality operator for a type which has a subcomponent
|
||||
-- of an Unchecked_Union type whose nominal subtype is unconstrained.
|
||||
|
|
@ -13132,23 +13016,11 @@ package body Exp_Ch4 is
|
|||
if (Is_Entity_Name (Alt) and then Is_Type (Entity (Alt)))
|
||||
or else Nkind (Alt) = N_Range
|
||||
then
|
||||
Cond :=
|
||||
Make_In (Sloc (Alt),
|
||||
Left_Opnd => L,
|
||||
Right_Opnd => R);
|
||||
Cond := Make_In (Sloc (Alt), Left_Opnd => L, Right_Opnd => R);
|
||||
|
||||
else
|
||||
Cond :=
|
||||
Make_Op_Eq (Sloc (Alt),
|
||||
Left_Opnd => L,
|
||||
Right_Opnd => R);
|
||||
|
||||
if Is_Record_Or_Limited_Type (Etype (Alt)) then
|
||||
|
||||
-- We reset the Entity in order to use the primitive equality
|
||||
-- of the type, as per RM 4.5.2 (28.1/4).
|
||||
|
||||
Set_Entity (Cond, Empty);
|
||||
end if;
|
||||
Cond := Make_Op_Eq (Sloc (Alt), Left_Opnd => L, Right_Opnd => R);
|
||||
Resolve_Membership_Equality (Cond, Etype (Alt));
|
||||
end if;
|
||||
|
||||
return Cond;
|
||||
|
|
|
|||
|
|
@ -4475,16 +4475,6 @@ package body Exp_Ch6 is
|
|||
|
||||
Set_Entity (Name (Call_Node), Parent_Subp);
|
||||
|
||||
-- Move this check to sem???
|
||||
|
||||
if Is_Abstract_Subprogram (Parent_Subp)
|
||||
and then not In_Instance
|
||||
then
|
||||
Error_Msg_NE
|
||||
("cannot call abstract subprogram &!",
|
||||
Name (Call_Node), Parent_Subp);
|
||||
end if;
|
||||
|
||||
-- Inspect all formals of derived subprogram Subp. Compare parameter
|
||||
-- types with the parent subprogram and check whether an actual may
|
||||
-- need a type conversion to the corresponding formal of the parent
|
||||
|
|
|
|||
|
|
@ -1261,15 +1261,6 @@ package body Sem_Aux is
|
|||
end if;
|
||||
end Is_Limited_View;
|
||||
|
||||
-------------------------------
|
||||
-- Is_Record_Or_Limited_Type --
|
||||
-------------------------------
|
||||
|
||||
function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean is
|
||||
begin
|
||||
return Is_Record_Type (Typ) or else Is_Limited_Type (Typ);
|
||||
end Is_Record_Or_Limited_Type;
|
||||
|
||||
----------------------
|
||||
-- Nearest_Ancestor --
|
||||
----------------------
|
||||
|
|
|
|||
|
|
@ -334,9 +334,6 @@ package Sem_Aux is
|
|||
-- these types). This older routine overlaps with the previous one, this
|
||||
-- should be cleaned up???
|
||||
|
||||
function Is_Record_Or_Limited_Type (Typ : Entity_Id) return Boolean;
|
||||
-- Return True if Typ requires is a record or limited type.
|
||||
|
||||
function Nearest_Ancestor (Typ : Entity_Id) return Entity_Id;
|
||||
-- Given a subtype Typ, this function finds out the nearest ancestor from
|
||||
-- which constraints and predicates are inherited. There is no simple link
|
||||
|
|
|
|||
|
|
@ -1253,19 +1253,11 @@ package body Sem_Ch4 is
|
|||
-- If the nonoverloaded interpretation is a call to an abstract
|
||||
-- nondispatching operation, then flag an error and return.
|
||||
|
||||
-- Should this be incorporated in Remove_Abstract_Operations (which
|
||||
-- currently only deals with cases where the name is overloaded)? ???
|
||||
|
||||
if Is_Overloadable (Nam_Ent)
|
||||
and then Is_Abstract_Subprogram (Nam_Ent)
|
||||
and then not Is_Dispatching_Operation (Nam_Ent)
|
||||
then
|
||||
Set_Etype (N, Any_Type);
|
||||
|
||||
Error_Msg_Sloc := Sloc (Nam_Ent);
|
||||
Error_Msg_NE
|
||||
("cannot call abstract operation& declared#", N, Nam_Ent);
|
||||
|
||||
Nondispatching_Call_To_Abstract_Operation (N, Nam_Ent);
|
||||
return;
|
||||
end if;
|
||||
|
||||
|
|
@ -3386,18 +3378,11 @@ package body Sem_Ch4 is
|
|||
Check_Fully_Declared (Entity (R), R);
|
||||
|
||||
elsif Ada_Version >= Ada_2012 and then Find_Interp then
|
||||
if Nkind (N) = N_In then
|
||||
Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
else
|
||||
Op := Make_Op_Ne (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
end if;
|
||||
Op := Make_Op_Eq (Loc, Left_Opnd => L, Right_Opnd => R);
|
||||
Resolve_Membership_Equality (Op, Etype (L));
|
||||
|
||||
if Is_Record_Or_Limited_Type (Etype (L)) then
|
||||
|
||||
-- We reset the Entity in order to use the primitive equality
|
||||
-- of the type, as per RM 4.5.2 (28.1/4).
|
||||
|
||||
Set_Entity (Op, Empty);
|
||||
if Nkind (N) = N_Not_In then
|
||||
Op := Make_Op_Not (Loc, Op);
|
||||
end if;
|
||||
|
||||
Rewrite (N, Op);
|
||||
|
|
@ -7872,6 +7857,42 @@ package body Sem_Ch4 is
|
|||
return Etype (N) /= Any_Type;
|
||||
end Has_Possible_Literal_Aspects;
|
||||
|
||||
-----------------------------------------------
|
||||
-- Nondispatching_Call_To_Abstract_Operation --
|
||||
-----------------------------------------------
|
||||
|
||||
procedure Nondispatching_Call_To_Abstract_Operation
|
||||
(N : Node_Id;
|
||||
Abstract_Op : Entity_Id)
|
||||
is
|
||||
Typ : constant Entity_Id := Etype (N);
|
||||
|
||||
begin
|
||||
-- In an instance body, this is a runtime check, but one we know will
|
||||
-- fail, so give an appropriate warning. As usual this kind of warning
|
||||
-- is an error in SPARK mode.
|
||||
|
||||
Error_Msg_Sloc := Sloc (Abstract_Op);
|
||||
|
||||
if In_Instance_Body and then SPARK_Mode /= On then
|
||||
Error_Msg_NE
|
||||
("??cannot call abstract operation& declared#",
|
||||
N, Abstract_Op);
|
||||
Error_Msg_N ("\Program_Error [??", N);
|
||||
Rewrite (N,
|
||||
Make_Raise_Program_Error (Sloc (N),
|
||||
Reason => PE_Explicit_Raise));
|
||||
Analyze (N);
|
||||
Set_Etype (N, Typ);
|
||||
|
||||
else
|
||||
Error_Msg_NE
|
||||
("cannot call abstract operation& declared#",
|
||||
N, Abstract_Op);
|
||||
Set_Etype (N, Any_Type);
|
||||
end if;
|
||||
end Nondispatching_Call_To_Abstract_Operation;
|
||||
|
||||
----------------------------------------------
|
||||
-- Possible_Type_For_Conditional_Expression --
|
||||
----------------------------------------------
|
||||
|
|
@ -8191,10 +8212,7 @@ package body Sem_Ch4 is
|
|||
|
||||
-- Removal of abstract operation left no viable candidate
|
||||
|
||||
Set_Etype (N, Any_Type);
|
||||
Error_Msg_Sloc := Sloc (Abstract_Op);
|
||||
Error_Msg_NE
|
||||
("cannot call abstract operation& declared#", N, Abstract_Op);
|
||||
Nondispatching_Call_To_Abstract_Operation (N, Abstract_Op);
|
||||
|
||||
-- In Ada 2005, an abstract operation may disable predefined
|
||||
-- operators. Since the context is not yet known, we mark the
|
||||
|
|
|
|||
|
|
@ -67,6 +67,12 @@ package Sem_Ch4 is
|
|||
-- The resolution of the construct requires some semantic information
|
||||
-- on the prefix and the indexes.
|
||||
|
||||
procedure Nondispatching_Call_To_Abstract_Operation
|
||||
(N : Node_Id;
|
||||
Abstract_Op : Entity_Id);
|
||||
-- Give an error, or a warning and rewrite N to raise Program_Error because
|
||||
-- it is a nondispatching call to an abstract operation.
|
||||
|
||||
function Try_Object_Operation
|
||||
(N : Node_Id;
|
||||
CW_Test_Only : Boolean := False;
|
||||
|
|
|
|||
|
|
@ -190,14 +190,12 @@ package body Sem_Ch6 is
|
|||
-- 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. In Ada 2012 mode,
|
||||
-- this routine outputs errors (or warnings if -gnatd.E is set). In earlier
|
||||
-- versions of Ada, warnings are output if Warn_On_Ada_2012_Incompatibility
|
||||
-- is set, otherwise the call has no effect.
|
||||
-- In Ada 2012, a primitive equality operator for an untagged record type
|
||||
-- must appear before the type is frozen. This procedure checks that this
|
||||
-- rule is met, and otherwise gives an error on the subprogram declaration
|
||||
-- and a warning on the earlier freeze point if it is easy to pinpoint. In
|
||||
-- earlier versions of Ada, the call has not effect, unless compatibility
|
||||
-- warnings are requested by means of Warn_On_Ada_2012_Incompatibility.
|
||||
|
||||
procedure Enter_Overloaded_Entity (S : Entity_Id);
|
||||
-- This procedure makes S, a new overloaded entity, into the first visible
|
||||
|
|
@ -9511,12 +9509,12 @@ package body Sem_Ch6 is
|
|||
|
||||
begin
|
||||
-- This check applies only if we have a subprogram declaration with an
|
||||
-- untagged record type that is conformant to the predefined op.
|
||||
-- untagged record type that is conformant to the predefined operator.
|
||||
|
||||
if Nkind (Decl) /= N_Subprogram_Declaration
|
||||
or else not Is_Record_Type (Typ)
|
||||
or else Is_Tagged_Type (Typ)
|
||||
or else Etype (Next_Formal (First_Formal (Eq_Op))) /= Typ
|
||||
or else not Is_User_Defined_Equality (Eq_Op)
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
|
@ -9628,22 +9626,7 @@ package body Sem_Ch6 is
|
|||
end if;
|
||||
end if;
|
||||
|
||||
-- Here if type is not frozen yet. It is illegal to have a primitive
|
||||
-- equality declared in the private part if the type is visible
|
||||
-- (RM 4.5.2(9.8)).
|
||||
|
||||
elsif not In_Same_List (Parent (Typ), Decl)
|
||||
and then not Is_Limited_Type (Typ)
|
||||
then
|
||||
if Ada_Version >= Ada_2012 then
|
||||
Error_Msg_N
|
||||
("equality operator appears too late<<", Eq_Op);
|
||||
else
|
||||
Error_Msg_N
|
||||
("equality operator appears too late (Ada 2012)?y?", Eq_Op);
|
||||
end if;
|
||||
|
||||
-- Finally check for AI12-0352: declaration of a user-defined primitive
|
||||
-- Now check for AI12-0352: the 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.
|
||||
|
||||
|
|
|
|||
|
|
@ -1313,6 +1313,11 @@ package body Sem_Ch7 is
|
|||
-- Reject completion of an incomplete or private type declarations
|
||||
-- having a known discriminant part by an unchecked union.
|
||||
|
||||
procedure Inspect_Untagged_Record_Completion (Decls : List_Id);
|
||||
-- Find out whether a nonlimited untagged record completion has got a
|
||||
-- primitive equality operator and, if so, make it so that it will be
|
||||
-- used as the predefined operator of the private view of the record.
|
||||
|
||||
procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id);
|
||||
-- Given the package entity of a generic package instantiation or
|
||||
-- formal package whose corresponding generic is a child unit, installs
|
||||
|
|
@ -1437,7 +1442,7 @@ package body Sem_Ch7 is
|
|||
Decl := First (Decls);
|
||||
while Present (Decl) loop
|
||||
|
||||
-- We are looking at an incomplete or private type declaration
|
||||
-- We are looking for an incomplete or private type declaration
|
||||
-- with a known_discriminant_part whose full view is an
|
||||
-- Unchecked_Union. The seemingly useless check with Is_Type
|
||||
-- prevents cascaded errors when routines defined only for type
|
||||
|
|
@ -1461,6 +1466,79 @@ package body Sem_Ch7 is
|
|||
end loop;
|
||||
end Inspect_Unchecked_Union_Completion;
|
||||
|
||||
----------------------------------------
|
||||
-- Inspect_Untagged_Record_Completion --
|
||||
----------------------------------------
|
||||
|
||||
procedure Inspect_Untagged_Record_Completion (Decls : List_Id) is
|
||||
Decl : Node_Id;
|
||||
|
||||
begin
|
||||
Decl := First (Decls);
|
||||
while Present (Decl) loop
|
||||
|
||||
-- We are looking for a full type declaration of an untagged
|
||||
-- record with a private declaration and primitive operations.
|
||||
|
||||
if Nkind (Decl) in N_Full_Type_Declaration
|
||||
and then Is_Record_Type (Defining_Identifier (Decl))
|
||||
and then not Is_Limited_Type (Defining_Identifier (Decl))
|
||||
and then not Is_Tagged_Type (Defining_Identifier (Decl))
|
||||
and then Has_Private_Declaration (Defining_Identifier (Decl))
|
||||
and then Has_Primitive_Operations (Defining_Identifier (Decl))
|
||||
then
|
||||
declare
|
||||
Prim_List : constant Elist_Id :=
|
||||
Collect_Primitive_Operations (Defining_Identifier (Decl));
|
||||
|
||||
Ne_Id : Entity_Id;
|
||||
Op_Decl : Node_Id;
|
||||
Op_Id : Entity_Id;
|
||||
Prim : Elmt_Id;
|
||||
|
||||
begin
|
||||
Prim := First_Elmt (Prim_List);
|
||||
while Present (Prim) loop
|
||||
Op_Id := Node (Prim);
|
||||
Op_Decl := Declaration_Node (Op_Id);
|
||||
if Nkind (Op_Decl) in N_Subprogram_Specification then
|
||||
Op_Decl := Parent (Op_Decl);
|
||||
end if;
|
||||
|
||||
-- We are looking for an equality operator immediately
|
||||
-- visible and declared in the private part followed by
|
||||
-- the synthesized inequality operator.
|
||||
|
||||
if Is_User_Defined_Equality (Op_Id)
|
||||
and then Is_Immediately_Visible (Op_Id)
|
||||
and then List_Containing (Op_Decl) = Decls
|
||||
then
|
||||
Ne_Id := Next_Entity (Op_Id);
|
||||
pragma Assert (Ekind (Ne_Id) = E_Function
|
||||
and then Corresponding_Equality (Ne_Id) = Op_Id);
|
||||
|
||||
-- Move them from the private part of the entity list
|
||||
-- up to the end of the visible part of the same list.
|
||||
|
||||
Remove_Entity (Op_Id);
|
||||
Remove_Entity (Ne_Id);
|
||||
|
||||
Link_Entities
|
||||
(Prev_Entity (First_Private_Entity (Id)), Op_Id);
|
||||
Link_Entities (Op_Id, Ne_Id);
|
||||
Link_Entities (Ne_Id, First_Private_Entity (Id));
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim);
|
||||
end loop;
|
||||
end;
|
||||
end if;
|
||||
|
||||
Next (Decl);
|
||||
end loop;
|
||||
end Inspect_Untagged_Record_Completion;
|
||||
|
||||
-----------------------------------------
|
||||
-- Install_Parent_Private_Declarations --
|
||||
-----------------------------------------
|
||||
|
|
@ -1718,7 +1796,7 @@ package body Sem_Ch7 is
|
|||
end if;
|
||||
|
||||
-- Analyze private part if present. The flag In_Private_Part is reset
|
||||
-- in End_Package_Scope.
|
||||
-- in Uninstall_Declarations.
|
||||
|
||||
L := Last_Entity (Id);
|
||||
|
||||
|
|
@ -1815,6 +1893,14 @@ package body Sem_Ch7 is
|
|||
Inspect_Unchecked_Union_Completion (Priv_Decls);
|
||||
end if;
|
||||
|
||||
-- Implement AI12-0101 (which only removes a legality rule) and then
|
||||
-- AI05-0123 (which directly applies in the previously illegal case)
|
||||
-- in Ada 2012. Note that AI12-0101 is a binding interpretation.
|
||||
|
||||
if Present (Priv_Decls) and then Ada_Version >= Ada_2012 then
|
||||
Inspect_Untagged_Record_Completion (Priv_Decls);
|
||||
end if;
|
||||
|
||||
if Ekind (Id) = E_Generic_Package
|
||||
and then Nkind (Orig_Decl) = N_Generic_Package_Declaration
|
||||
and then Present (Priv_Decls)
|
||||
|
|
@ -2172,9 +2258,8 @@ package body Sem_Ch7 is
|
|||
-- a derived scalar type). Further declarations cannot
|
||||
-- include inherited operations of the type.
|
||||
|
||||
if Present (Prim_Op) then
|
||||
exit when Ekind (Prim_Op) not in Overloadable_Kind;
|
||||
end if;
|
||||
exit when Present (Prim_Op)
|
||||
and then not Is_Overloadable (Prim_Op);
|
||||
end loop;
|
||||
end if;
|
||||
end if;
|
||||
|
|
@ -3093,10 +3178,12 @@ package body Sem_Ch7 is
|
|||
|
||||
if not In_Private_Part (P) then
|
||||
return;
|
||||
else
|
||||
Set_In_Private_Part (P, False);
|
||||
end if;
|
||||
|
||||
-- Reset the flag now
|
||||
|
||||
Set_In_Private_Part (P, False);
|
||||
|
||||
-- Make private entities invisible and exchange full and private
|
||||
-- declarations for private types. Id is now the first private entity
|
||||
-- in the package.
|
||||
|
|
|
|||
|
|
@ -566,7 +566,10 @@ package body Sem_Disp is
|
|||
-- when it is user-defined.
|
||||
|
||||
if Is_Predefined_Dispatching_Operation (Subp_Entity)
|
||||
and then not Is_User_Defined_Equality (Subp_Entity)
|
||||
and then not (Is_User_Defined_Equality (Subp_Entity)
|
||||
and then Comes_From_Source (Subp_Entity)
|
||||
and then Nkind (Parent (Subp_Entity)) =
|
||||
N_Function_Specification)
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
|
|
|||
|
|
@ -3215,11 +3215,11 @@ package body Sem_Res is
|
|||
then
|
||||
Get_First_Interp (N, I, It);
|
||||
while Present (It.Typ) loop
|
||||
if Present (It.Abstract_Op) and then
|
||||
Etype (It.Abstract_Op) = Typ
|
||||
if Present (It.Abstract_Op)
|
||||
and then Etype (It.Abstract_Op) = Typ
|
||||
then
|
||||
Error_Msg_NE
|
||||
("cannot call abstract subprogram &!", N, It.Abstract_Op);
|
||||
Nondispatching_Call_To_Abstract_Operation
|
||||
(N, It.Abstract_Op);
|
||||
return;
|
||||
end if;
|
||||
|
||||
|
|
@ -7063,24 +7063,19 @@ package body Sem_Res is
|
|||
-- If the subprogram is a primitive operation, check whether or not
|
||||
-- it is a correct dispatching call.
|
||||
|
||||
if Is_Overloadable (Nam)
|
||||
and then Is_Dispatching_Operation (Nam)
|
||||
then
|
||||
if Is_Overloadable (Nam) and then Is_Dispatching_Operation (Nam) then
|
||||
Check_Dispatching_Call (N);
|
||||
|
||||
elsif Ekind (Nam) /= E_Subprogram_Type
|
||||
and then Is_Abstract_Subprogram (Nam)
|
||||
and then not In_Instance
|
||||
then
|
||||
Error_Msg_NE ("cannot call abstract subprogram &!", N, Nam);
|
||||
-- If the subprogram is an abstract operation, then flag an error
|
||||
|
||||
elsif Is_Overloadable (Nam) and then Is_Abstract_Subprogram (Nam) then
|
||||
Nondispatching_Call_To_Abstract_Operation (N, Nam);
|
||||
end if;
|
||||
|
||||
-- If this is a dispatching call, generate the appropriate reference,
|
||||
-- for better source navigation in GNAT Studio.
|
||||
|
||||
if Is_Overloadable (Nam)
|
||||
and then Present (Controlling_Argument (N))
|
||||
then
|
||||
if Is_Overloadable (Nam) and then Present (Controlling_Argument (N)) then
|
||||
Generate_Reference (Nam, Subp, 'R');
|
||||
|
||||
-- Normal case, not a dispatching call: generate a call reference
|
||||
|
|
@ -8918,6 +8913,41 @@ package body Sem_Res is
|
|||
Resolve (L, T);
|
||||
Resolve (R, T);
|
||||
|
||||
-- AI12-0413: user-defined primitive equality of an untagged record
|
||||
-- type hides the predefined equality operator, including within a
|
||||
-- generic, and if it is declared abstract, results in an illegal
|
||||
-- instance if the operator is used in the spec, or in the raising
|
||||
-- of Program_Error if used in the body of an instance.
|
||||
|
||||
if Nkind (N) = N_Op_Eq
|
||||
and then In_Instance
|
||||
and then Ada_Version >= Ada_2012
|
||||
then
|
||||
declare
|
||||
U : constant Entity_Id := Underlying_Type (T);
|
||||
|
||||
Eq : Entity_Id;
|
||||
|
||||
begin
|
||||
if Present (U)
|
||||
and then Is_Record_Type (U)
|
||||
and then not Is_Tagged_Type (U)
|
||||
then
|
||||
Eq := Get_User_Defined_Equality (T);
|
||||
|
||||
if Present (Eq) then
|
||||
if Is_Abstract_Subprogram (Eq) then
|
||||
Nondispatching_Call_To_Abstract_Operation (N, Eq);
|
||||
else
|
||||
Rewrite_Operator_As_Call (N, Eq);
|
||||
end if;
|
||||
|
||||
return;
|
||||
end if;
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- If the unique type is a class-wide type then it will be expanded
|
||||
-- into a dispatching call to the predefined primitive. Therefore we
|
||||
-- check here for potential violation of such restriction.
|
||||
|
|
@ -8977,8 +9007,8 @@ package body Sem_Res is
|
|||
if Nkind (N) = N_Op_Eq
|
||||
or else Comes_From_Source (Entity (N))
|
||||
or else Ekind (Entity (N)) = E_Operator
|
||||
or else Is_Intrinsic_Subprogram
|
||||
(Corresponding_Equality (Entity (N)))
|
||||
or else
|
||||
Is_Intrinsic_Subprogram (Corresponding_Equality (Entity (N)))
|
||||
then
|
||||
Analyze_Dimension (N);
|
||||
Eval_Relational_Op (N);
|
||||
|
|
@ -8986,7 +9016,7 @@ package body Sem_Res is
|
|||
elsif Nkind (N) = N_Op_Ne
|
||||
and then Is_Abstract_Subprogram (Entity (N))
|
||||
then
|
||||
Error_Msg_NE ("cannot call abstract subprogram &!", N, Entity (N));
|
||||
Nondispatching_Call_To_Abstract_Operation (N, Entity (N));
|
||||
end if;
|
||||
end if;
|
||||
end Resolve_Equality_Op;
|
||||
|
|
@ -9837,6 +9867,38 @@ package body Sem_Res is
|
|||
Eval_Logical_Op (N);
|
||||
end Resolve_Logical_Op;
|
||||
|
||||
---------------------------------
|
||||
-- Resolve_Membership_Equality --
|
||||
---------------------------------
|
||||
|
||||
procedure Resolve_Membership_Equality (N : Node_Id; Typ : Entity_Id) is
|
||||
Utyp : constant Entity_Id := Underlying_Type (Typ);
|
||||
|
||||
begin
|
||||
-- RM 4.5.2(4.1/3): if the type is limited, then it shall have a visible
|
||||
-- primitive equality operator. This means that we can use the regular
|
||||
-- visibility-based resolution and reset Entity in order to trigger it.
|
||||
|
||||
if Is_Limited_Type (Typ) then
|
||||
Set_Entity (N, Empty);
|
||||
|
||||
-- RM 4.5.2(28.1/3): if the type is a record, then the membership test
|
||||
-- uses the primitive equality for the type [even if it is not visible].
|
||||
-- We only deal with the untagged case here, because the tagged case is
|
||||
-- handled uniformly in the expander.
|
||||
|
||||
elsif Is_Record_Type (Utyp) and then not Is_Tagged_Type (Utyp) then
|
||||
declare
|
||||
Eq_Id : constant Entity_Id := Get_User_Defined_Equality (Typ);
|
||||
|
||||
begin
|
||||
if Present (Eq_Id) then
|
||||
Rewrite_Operator_As_Call (N, Eq_Id);
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
end Resolve_Membership_Equality;
|
||||
|
||||
---------------------------
|
||||
-- Resolve_Membership_Op --
|
||||
---------------------------
|
||||
|
|
@ -9953,7 +10015,7 @@ package body Sem_Res is
|
|||
-- following warning appears useful for the most common case.
|
||||
|
||||
if Is_Scalar_Type (Etype (L))
|
||||
and then Present (Get_User_Defined_Eq (Etype (L)))
|
||||
and then Present (Get_User_Defined_Equality (Etype (L)))
|
||||
then
|
||||
Error_Msg_NE
|
||||
("membership test on& uses predefined equality?", N, Etype (L));
|
||||
|
|
|
|||
|
|
@ -125,6 +125,9 @@ package Sem_Res is
|
|||
-- own type. For now we assume that the prefix cannot be overloaded and
|
||||
-- the name of the entry plays no role in the resolution.
|
||||
|
||||
procedure Resolve_Membership_Equality (N : Node_Id; Typ : Entity_Id);
|
||||
-- Resolve the equality operator in an individual membership test
|
||||
|
||||
function Valid_Conversion
|
||||
(N : Node_Id;
|
||||
Target : Entity_Id;
|
||||
|
|
|
|||
|
|
@ -11770,32 +11770,25 @@ package body Sem_Util is
|
|||
return Task_Body_Procedure (Underlying_Type (Root_Type (E)));
|
||||
end Get_Task_Body_Procedure;
|
||||
|
||||
-------------------------
|
||||
-- Get_User_Defined_Eq --
|
||||
-------------------------
|
||||
-------------------------------
|
||||
-- Get_User_Defined_Equality --
|
||||
-------------------------------
|
||||
|
||||
function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id is
|
||||
function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id is
|
||||
Prim : Elmt_Id;
|
||||
Op : Entity_Id;
|
||||
|
||||
begin
|
||||
Prim := First_Elmt (Collect_Primitive_Operations (E));
|
||||
while Present (Prim) loop
|
||||
Op := Node (Prim);
|
||||
|
||||
if Chars (Op) = Name_Op_Eq
|
||||
and then Etype (Op) = Standard_Boolean
|
||||
and then Etype (First_Formal (Op)) = E
|
||||
and then Etype (Next_Formal (First_Formal (Op))) = E
|
||||
then
|
||||
return Op;
|
||||
if Is_User_Defined_Equality (Node (Prim)) then
|
||||
return Node (Prim);
|
||||
end if;
|
||||
|
||||
Next_Elmt (Prim);
|
||||
end loop;
|
||||
|
||||
return Empty;
|
||||
end Get_User_Defined_Eq;
|
||||
end Get_User_Defined_Equality;
|
||||
|
||||
---------------
|
||||
-- Get_Views --
|
||||
|
|
@ -21498,15 +21491,31 @@ package body Sem_Util is
|
|||
------------------------------
|
||||
|
||||
function Is_User_Defined_Equality (Id : Entity_Id) return Boolean is
|
||||
F1, F2 : Entity_Id;
|
||||
|
||||
begin
|
||||
return Ekind (Id) = E_Function
|
||||
-- An equality operator is a function that carries the name "=", returns
|
||||
-- Boolean, and has exactly two formal parameters of an identical type.
|
||||
|
||||
if Ekind (Id) = E_Function
|
||||
and then Chars (Id) = Name_Op_Eq
|
||||
and then Comes_From_Source (Id)
|
||||
and then Base_Type (Etype (Id)) = Standard_Boolean
|
||||
then
|
||||
F1 := First_Formal (Id);
|
||||
|
||||
-- Internally generated equalities have a full type declaration
|
||||
-- as their parent.
|
||||
if No (F1) then
|
||||
return False;
|
||||
end if;
|
||||
|
||||
and then Nkind (Parent (Id)) = N_Function_Specification;
|
||||
F2 := Next_Formal (F1);
|
||||
|
||||
return Present (F2)
|
||||
and then No (Next_Formal (F2))
|
||||
and then Base_Type (Etype (F1)) = Base_Type (Etype (F2));
|
||||
|
||||
else
|
||||
return False;
|
||||
end if;
|
||||
end Is_User_Defined_Equality;
|
||||
|
||||
-----------------------------
|
||||
|
|
|
|||
|
|
@ -1338,7 +1338,7 @@ package Sem_Util is
|
|||
-- Given an entity for a task type or subtype, retrieves the
|
||||
-- Task_Body_Procedure field from the corresponding task type declaration.
|
||||
|
||||
function Get_User_Defined_Eq (E : Entity_Id) return Entity_Id;
|
||||
function Get_User_Defined_Equality (E : Entity_Id) return Entity_Id;
|
||||
-- For a type entity, return the entity of the primitive equality function
|
||||
-- for the type if it exists, otherwise return Empty.
|
||||
|
||||
|
|
|
|||
|
|
@ -2826,7 +2826,7 @@ package Sinfo is
|
|||
-- Defining_Identifier
|
||||
-- Null_Exclusion_Present
|
||||
-- Subtype_Indication
|
||||
-- Generic_Parent_Type (set for an actual derived type).
|
||||
-- Generic_Parent_Type (for actual of formal private or derived type)
|
||||
-- Exception_Junk
|
||||
|
||||
-------------------------------
|
||||
|
|
|
|||
|
|
@ -105,7 +105,8 @@ package Uintp is
|
|||
subtype Upos is Valid_Uint with Predicate => Upos >= Uint_1; -- positive
|
||||
subtype Nonzero_Uint is Valid_Uint with Predicate => Nonzero_Uint /= Uint_0;
|
||||
subtype Unegative is Valid_Uint with Predicate => Unegative < Uint_0;
|
||||
subtype Ubool is Valid_Uint with Predicate => Ubool in Uint_0 | Uint_1;
|
||||
subtype Ubool is Valid_Uint with
|
||||
Predicate => Ubool = Uint_0 or else Ubool = Uint_1;
|
||||
subtype Opt_Ubool is Uint with
|
||||
Predicate => No (Opt_Ubool) or else Opt_Ubool in Ubool;
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue