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.
-- 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;
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;
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;
-- 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
-- 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);
- Set_Is_Abstract_Subprogram
- (Op, Is_Abstract_Subprogram (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
- (Next_Entity (Op), Is_Abstract_Subprogram (NE_Op));
- end if;
+ if Chars (Next_Entity (Op)) = Name_Op_Ne then
+ Set_Is_Abstract_Subprogram
+ (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
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 --
----------------------------------------
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;
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;
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
-- 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.
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 --
-------------------
Candid := Prim;
while Present (Candid) loop
- if Is_Equality (Candid) then
+ if Is_User_Defined_Equality (Candid) then
return Candid;
end if;
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 --
------------------------------------
-- 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
(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.
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);
- else
- Cond :=
- Make_Op_Eq (Sloc (Alt),
- Left_Opnd => L,
- Right_Opnd => R);
-
- if Is_Record_Or_Limited_Type (Etype (Alt)) then
+ Cond := Make_In (Sloc (Alt), Left_Opnd => L, Right_Opnd => R);
- -- 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;
+ else
+ Cond := Make_Op_Eq (Sloc (Alt), Left_Opnd => L, Right_Opnd => R);
+ Resolve_Membership_Equality (Cond, Etype (Alt));
end if;
return Cond;
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
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 --
----------------------
-- 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
-- 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;
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);
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 --
----------------------------------------------
-- 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
-- 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;
-- 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
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;
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.
-- 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
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
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 --
-----------------------------------------
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);
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)
-- 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;
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.
-- 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;
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;
-- 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
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.
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);
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;
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 --
---------------------------
-- 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));
-- 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;
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 --
------------------------------
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);
+
+ if No (F1) then
+ return False;
+ end if;
- -- Internally generated equalities have a full type declaration
- -- as their parent.
+ F2 := Next_Formal (F1);
- and then Nkind (Parent (Id)) = N_Function_Specification;
+ 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;
-----------------------------
-- 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.
-- 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
-------------------------------
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;