-- of a record type that has user-defined primitive equality operations.
-- The resulting operation is a TSS subprogram.
- procedure Build_Variant_Record_Equality (Typ : Entity_Id);
- -- Create An Equality function for the untagged variant record Typ and
- -- attach it to the TSS list
-
procedure Check_Stream_Attributes (Typ : Entity_Id);
-- Check that if a limited extension has a parent with user-defined stream
-- attributes, and does not itself have user-defined stream-attributes,
-- Generates:
- -- function _Equality (X, Y : T) return Boolean is
+ -- function <<Body_Id>> (Left, Right : T) return Boolean is
+ -- [ X : T renames Left; ]
+ -- [ Y : T renames Right; ]
+ -- -- The above renamings are generated only if the parameters of
+ -- -- this built function (which are passed by the caller) are not
+ -- -- named 'X' and 'Y'; these names are required to reuse several
+ -- -- expander routines when generating this body.
+
-- begin
-- -- Compare discriminants
-- return True;
-- end _Equality;
- procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
- Loc : constant Source_Ptr := Sloc (Typ);
-
- F : constant Entity_Id :=
- Make_Defining_Identifier (Loc,
- Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
-
- X : constant Entity_Id := Make_Defining_Identifier (Loc, Name_X);
- Y : constant Entity_Id := Make_Defining_Identifier (Loc, Name_Y);
-
- Def : constant Node_Id := Parent (Typ);
- Comps : constant Node_Id := Component_List (Type_Definition (Def));
- Stmts : constant List_Id := New_List;
- Pspecs : constant List_Id := New_List;
+ function Build_Variant_Record_Equality
+ (Typ : Entity_Id;
+ Body_Id : Entity_Id;
+ Param_Specs : List_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Def : constant Node_Id := Parent (Typ);
+ Comps : constant Node_Id := Component_List (Type_Definition (Def));
+ Left : constant Entity_Id := Defining_Identifier
+ (First (Param_Specs));
+ Right : constant Entity_Id := Defining_Identifier
+ (Next (First (Param_Specs)));
+ Decls : constant List_Id := New_List;
+ Stmts : constant List_Id := New_List;
+ Subp_Body : Node_Id;
begin
- -- If we have a variant record with restriction No_Implicit_Conditionals
- -- in effect, then we skip building the procedure. This is safe because
- -- if we can see the restriction, so can any caller, calls to equality
- -- test routines are not allowed for variant records if this restriction
- -- is active.
-
- if Restriction_Active (No_Implicit_Conditionals) then
- return;
+ pragma Assert (not Is_Tagged_Type (Typ));
+
+ -- In order to reuse the expander routines Make_Eq_If and Make_Eq_Case
+ -- the name of the formals must be X and Y; otherwise we generate two
+ -- renaming declarations for such purpose.
+
+ if Chars (Left) /= Name_X then
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_X),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Name => Make_Identifier (Loc, Chars (Left))));
end if;
- -- Derived Unchecked_Union types no longer inherit the equality function
- -- of their parent.
-
- if Is_Derived_Type (Typ)
- and then not Is_Unchecked_Union (Typ)
- and then not Has_New_Non_Standard_Rep (Typ)
- then
- declare
- Parent_Eq : constant Entity_Id :=
- TSS (Root_Type (Typ), TSS_Composite_Equality);
- begin
- if Present (Parent_Eq) then
- Copy_TSS (Parent_Eq, Typ);
- return;
- end if;
- end;
+ if Chars (Right) /= Name_Y then
+ Append_To (Decls,
+ Make_Object_Renaming_Declaration (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_Y),
+ Subtype_Mark => New_Occurrence_Of (Typ, Loc),
+ Name => Make_Identifier (Loc, Chars (Right))));
end if;
- Discard_Node (
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => F,
- Parameter_Specifications => Pspecs,
- Result_Definition => New_Occurrence_Of (Standard_Boolean, Loc)),
- Declarations => New_List,
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc, Statements => Stmts)));
-
- Append_To (Pspecs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => X,
- Parameter_Type => New_Occurrence_Of (Typ, Loc)));
-
- Append_To (Pspecs,
- Make_Parameter_Specification (Loc,
- Defining_Identifier => Y,
- Parameter_Type => New_Occurrence_Of (Typ, Loc)));
-
-- Unchecked_Unions require additional machinery to support equality.
-- Two extra parameters (A and B) are added to the equality function
-- parameter list for each discriminant of the type, in order to
-- Add new parameters to the parameter list
- Append_To (Pspecs,
+ Append_To (Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier => A,
Parameter_Type =>
New_Occurrence_Of (Discr_Type, Loc)));
- Append_To (Pspecs,
+ Append_To (Param_Specs,
Make_Parameter_Specification (Loc,
Defining_Identifier => B,
Parameter_Type =>
Make_Simple_Return_Statement (Loc,
Expression => New_Occurrence_Of (Standard_True, Loc)));
- Set_TSS (Typ, F);
- Set_Is_Pure (F);
+ Subp_Body :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Body_Id,
+ Parameter_Specifications => Param_Specs,
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
+ Declarations => Decls,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => Stmts));
- if not Debug_Generated_Code then
- Set_Debug_Info_Off (F);
- end if;
+ return Subp_Body;
end Build_Variant_Record_Equality;
-----------------------------
-------------------------------
procedure Expand_Freeze_Record_Type (N : Node_Id) is
+ procedure Build_Variant_Record_Equality (Typ : Entity_Id);
+ -- Create An Equality function for the untagged variant record Typ and
+ -- attach it to the TSS list.
+
+ procedure Build_Variant_Record_Equality (Typ : Entity_Id) is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ F : constant Entity_Id :=
+ Make_Defining_Identifier (Loc,
+ Chars => Make_TSS_Name (Typ, TSS_Composite_Equality));
+ begin
+ -- For a variant record with restriction No_Implicit_Conditionals
+ -- in effect we skip building the procedure. This is safe because
+ -- if we can see the restriction, so can any caller, and calls to
+ -- equality test routines are not allowed for variant records if
+ -- this restriction is active.
+
+ if Restriction_Active (No_Implicit_Conditionals) then
+ return;
+ end if;
+
+ -- Derived Unchecked_Union types no longer inherit the equality
+ -- function of their parent.
+
+ if Is_Derived_Type (Typ)
+ and then not Is_Unchecked_Union (Typ)
+ and then not Has_New_Non_Standard_Rep (Typ)
+ then
+ declare
+ Parent_Eq : constant Entity_Id :=
+ TSS (Root_Type (Typ), TSS_Composite_Equality);
+ begin
+ if Present (Parent_Eq) then
+ Copy_TSS (Parent_Eq, Typ);
+ return;
+ end if;
+ end;
+ end if;
+
+ Discard_Node (
+ Build_Variant_Record_Equality
+ (Typ => Typ,
+ Body_Id => F,
+ Param_Specs => New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc,
+ Name_X),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)),
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc,
+ Name_Y),
+ Parameter_Type => New_Occurrence_Of (Typ, Loc)))));
+
+ Set_TSS (Typ, F);
+ Set_Is_Pure (F);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (F);
+ end if;
+ end Build_Variant_Record_Equality;
+
+ -- Local variables
+
Typ : constant Node_Id := Entity (N);
Typ_Decl : constant Node_Id := Parent (Typ);
with Atree; use Atree;
with Einfo; use Einfo;
+with Exp_Ch3; use Exp_Ch3;
with Exp_Ch4; use Exp_Ch4;
with Exp_Ch6; use Exp_Ch6;
with Exp_Dbug; use Exp_Dbug;
with Nlists; use Nlists;
with Opt; use Opt;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
Loc : constant Source_Ptr := Sloc (N);
Id : constant Entity_Id := Defining_Entity (N);
- function Build_Body_For_Renaming return Node_Id;
+ function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id;
-- Build and return the body for the renaming declaration of an equality
- -- or inequality operator.
+ -- or inequality operator of type Typ.
-----------------------------
-- Build_Body_For_Renaming --
-----------------------------
- function Build_Body_For_Renaming return Node_Id is
+ function Build_Body_For_Renaming (Typ : Entity_Id) return Node_Id is
+ Left : constant Entity_Id := First_Formal (Id);
+ Right : constant Entity_Id := Next_Formal (Left);
Body_Id : Entity_Id;
Decl : Node_Id;
Body_Id := Make_Defining_Identifier (Sloc (N), Chars (Id));
Set_Debug_Info_Needed (Body_Id);
- Decl :=
- Make_Subprogram_Body (Loc,
- Specification =>
- Make_Function_Specification (Loc,
- Defining_Unit_Name => Body_Id,
- Parameter_Specifications => Copy_Parameter_List (Id),
- Result_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loc)),
- Declarations => Empty_List,
- Handled_Statement_Sequence => Empty);
+ if Has_Variant_Part (Typ) then
+ Decl :=
+ Build_Variant_Record_Equality
+ (Typ => Typ,
+ Body_Id => Body_Id,
+ Param_Specs => Copy_Parameter_List (Id));
+
+ -- Build body for renamed equality, to capture its current
+ -- meaning. It may be redefined later, but the renaming is
+ -- elaborated where it occurs. This is technically known as
+ -- Squirreling semantics. Renaming is rewritten as a subprogram
+ -- declaration, and the generated body is inserted into the
+ -- freeze actions for the subprogram.
+
+ else
+ Decl :=
+ Make_Subprogram_Body (Loc,
+ Specification =>
+ Make_Function_Specification (Loc,
+ Defining_Unit_Name => Body_Id,
+ Parameter_Specifications => Copy_Parameter_List (Id),
+ Result_Definition =>
+ New_Occurrence_Of (Standard_Boolean, Loc)),
+ Declarations => Empty_List,
+ Handled_Statement_Sequence => Empty);
+
+ Set_Handled_Statement_Sequence (Decl,
+ Make_Handled_Sequence_Of_Statements (Loc,
+ Statements => New_List (
+ Make_Simple_Return_Statement (Loc,
+ Expression =>
+ Expand_Record_Equality
+ (Id,
+ Typ => Typ,
+ Lhs => Make_Identifier (Loc, Chars (Left)),
+ Rhs => Make_Identifier (Loc, Chars (Right)),
+ Bodies => Declarations (Decl))))));
+ end if;
return Decl;
end Build_Body_For_Renaming;
and then Scope (Entity (Nam)) = Standard_Standard
then
declare
- Left : constant Entity_Id := First_Formal (Id);
- Right : constant Entity_Id := Next_Formal (Left);
- Typ : constant Entity_Id := Etype (Left);
- Decl : Node_Id;
+ Typ : constant Entity_Id := Etype (First_Formal (Id));
begin
-- Check whether this is a renaming of a predefined equality on an
and then not Is_Tagged_Type (Typ)
and then not Is_Frozen (Typ)
then
- -- Build body for renamed equality, to capture its current
- -- meaning. It may be redefined later, but the renaming is
- -- elaborated where it occurs. This is technically known as
- -- Squirreling semantics. Renaming is rewritten as a subprogram
- -- declaration, and the generated body is inserted into the
- -- freeze actions for the subprogram.
-
- Decl := Build_Body_For_Renaming;
-
- Set_Handled_Statement_Sequence (Decl,
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (
- Make_Simple_Return_Statement (Loc,
- Expression =>
- Expand_Record_Equality
- (Id,
- Typ => Typ,
- Lhs => Make_Identifier (Loc, Chars (Left)),
- Rhs => Make_Identifier (Loc, Chars (Right)),
- Bodies => Declarations (Decl))))));
-
- Append_Freeze_Action (Id, Decl);
+ Append_Freeze_Action (Id, Build_Body_For_Renaming (Typ));
end if;
end;
end if;
projects / gcc.git / commitdiff