-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2004, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2005, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
Make_Selected_Component (Loc,
Prefix => New_Reference_To (Temp, Loc),
Selector_Name =>
- New_Reference_To (Tag_Component (T), Loc)),
+ New_Reference_To (First_Tag_Component (T), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
- New_Reference_To (Access_Disp_Table (T), Loc)));
+ New_Reference_To
+ (Elists.Node (First_Elmt (Access_Disp_Table (T))),
+ Loc)));
-- The previous assignment has to be done in any case
Make_Selected_Component (Loc,
Prefix => Ref,
Selector_Name =>
- New_Reference_To (Tag_Component (Utyp), Loc)),
+ New_Reference_To (First_Tag_Component (Utyp), Loc)),
Expression =>
Unchecked_Convert_To (RTE (RE_Tag),
New_Reference_To (
- Access_Disp_Table (Utyp), Loc)));
+ Elists.Node (First_Elmt (Access_Disp_Table (Utyp))),
+ Loc)));
Set_Assignment_OK (Name (Tag_Assign));
Insert_Action (N, Tag_Assign);
Test := Expand_Composite_Equality
(Nod, Component_Type (Typ), L, R, Decls);
- return
- Make_Implicit_If_Statement (Nod,
- Condition => Make_Op_Not (Loc, Right_Opnd => Test),
- Then_Statements => New_List (
- Make_Return_Statement (Loc,
- Expression => New_Occurrence_Of (Standard_False, Loc))));
+ -- If some (sub)component is an unchecked_union, the whole operation
+ -- will raise program error.
+
+ if Nkind (Test) = N_Raise_Program_Error then
+
+ -- This node is going to be inserted at a location where a
+ -- statement is expected: clear its Etype so analysis will
+ -- set it to the expected Standard_Void_Type.
+
+ Set_Etype (Test, Empty);
+ return Test;
+
+ else
+ return
+ Make_Implicit_If_Statement (Nod,
+ Condition => Make_Op_Not (Loc, Right_Opnd => Test),
+ Then_Statements => New_List (
+ Make_Return_Statement (Loc,
+ Expression => New_Occurrence_Of (Standard_False, Loc))));
+ end if;
end Component_Equality;
------------------
Handle_One_Dimension (N + 1, Next_Index (Index)));
if Need_Separate_Indexes then
+
-- Generate guard for loop, followed by increments of indices
Append_To (Stm_List,
Expressions => New_List (New_Reference_To (Bn, Loc)))));
end if;
- -- If separate indexes, we need a declare block for An and Bn,
- -- and a loop without an iteration scheme.
+ -- If separate indexes, we need a declare block for An and Bn, and a
+ -- loop without an iteration scheme.
if Need_Separate_Indexes then
Loop_Stm :=
Typ : constant Entity_Id := Etype (N);
begin
- if Is_Bit_Packed_Array (Typ) then
+ -- Special case of bit packed array where both operands are known
+ -- to be properly aligned. In this case we use an efficient run time
+ -- routine to carry out the operation (see System.Bit_Ops).
+
+ if Is_Bit_Packed_Array (Typ)
+ and then not Is_Possibly_Unaligned_Object (Left_Opnd (N))
+ and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
+ then
Expand_Packed_Boolean_Operator (N);
+ return;
+ end if;
- else
- -- For the normal non-packed case, the general expansion is
- -- to build a function for carrying out the comparison (using
- -- Make_Boolean_Array_Op) and then inserting it into the tree.
- -- The original operator node is then rewritten as a call to
- -- this function.
+ -- For the normal non-packed case, the general expansion is to build
+ -- function for carrying out the comparison (use Make_Boolean_Array_Op)
+ -- and then inserting it into the tree. The original operator node is
+ -- then rewritten as a call to this function. We also use this in the
+ -- packed case if either operand is a possibly unaligned object.
- declare
- Loc : constant Source_Ptr := Sloc (N);
- L : constant Node_Id := Relocate_Node (Left_Opnd (N));
- R : constant Node_Id := Relocate_Node (Right_Opnd (N));
- Func_Body : Node_Id;
- Func_Name : Entity_Id;
+ declare
+ Loc : constant Source_Ptr := Sloc (N);
+ L : constant Node_Id := Relocate_Node (Left_Opnd (N));
+ R : constant Node_Id := Relocate_Node (Right_Opnd (N));
+ Func_Body : Node_Id;
+ Func_Name : Entity_Id;
- begin
- Convert_To_Actual_Subtype (L);
- Convert_To_Actual_Subtype (R);
- Ensure_Defined (Etype (L), N);
- Ensure_Defined (Etype (R), N);
- Apply_Length_Check (R, Etype (L));
-
- if Nkind (Parent (N)) = N_Assignment_Statement
- and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
- then
- Build_Boolean_Array_Proc_Call (Parent (N), L, R);
+ begin
+ Convert_To_Actual_Subtype (L);
+ Convert_To_Actual_Subtype (R);
+ Ensure_Defined (Etype (L), N);
+ Ensure_Defined (Etype (R), N);
+ Apply_Length_Check (R, Etype (L));
+
+ if Nkind (Parent (N)) = N_Assignment_Statement
+ and then Safe_In_Place_Array_Op (Name (Parent (N)), L, R)
+ then
+ Build_Boolean_Array_Proc_Call (Parent (N), L, R);
- elsif Nkind (Parent (N)) = N_Op_Not
- and then Nkind (N) = N_Op_And
- and then
- Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
- then
- return;
- else
+ elsif Nkind (Parent (N)) = N_Op_Not
+ and then Nkind (N) = N_Op_And
+ and then
+ Safe_In_Place_Array_Op (Name (Parent (Parent (N))), L, R)
+ then
+ return;
+ else
- Func_Body := Make_Boolean_Array_Op (Etype (L), N);
- Func_Name := Defining_Unit_Name (Specification (Func_Body));
- Insert_Action (N, Func_Body);
+ Func_Body := Make_Boolean_Array_Op (Etype (L), N);
+ Func_Name := Defining_Unit_Name (Specification (Func_Body));
+ Insert_Action (N, Func_Body);
- -- Now rewrite the expression with a call
+ -- Now rewrite the expression with a call
- Rewrite (N,
- Make_Function_Call (Loc,
- Name => New_Reference_To (Func_Name, Loc),
- Parameter_Associations =>
- New_List
- (L, Make_Type_Conversion
- (Loc, New_Reference_To (Etype (L), Loc), R))));
+ Rewrite (N,
+ Make_Function_Call (Loc,
+ Name => New_Reference_To (Func_Name, Loc),
+ Parameter_Associations =>
+ New_List (
+ L,
+ Make_Type_Conversion
+ (Loc, New_Reference_To (Etype (L), Loc), R))));
- Analyze_And_Resolve (N, Typ);
- end if;
- end;
- end if;
+ Analyze_And_Resolve (N, Typ);
+ end if;
+ end;
end Expand_Boolean_Operator;
-------------------------------
-- It is not possible to infer the discriminant since
-- the subtype is not constrained.
- Insert_Action (Nod,
+ return
Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
-
- -- Prevent Gigi from generating illegal code, change
- -- the equality to a standard False.
-
- return New_Occurrence_Of (Standard_False, Loc);
+ Reason => PE_Unchecked_Union_Restriction);
end if;
-- Rhs of the composite equality
end if;
else
- Insert_Action (Nod,
+ return
Make_Raise_Program_Error (Loc,
- Reason => PE_Unchecked_Union_Restriction));
-
- return Empty;
+ Reason => PE_Unchecked_Union_Restriction);
end if;
-- Call the TSS equality function with the inferred
(Typ : Node_Id) return Boolean
is
Tdef : constant Node_Id :=
- Type_Definition (Declaration_Node (Typ));
+ Type_Definition (Declaration_Node (Base_Type (Typ)));
Clist : Node_Id;
Vpart : Node_Id;
Force_Validity_Checks := Save_Force_Validity_Checks;
end;
- -- Packed case
+ -- Packed case where both operands are known aligned
- elsif Is_Bit_Packed_Array (Typl) then
+ elsif Is_Bit_Packed_Array (Typl)
+ and then not Is_Possibly_Unaligned_Object (Lhs)
+ and then not Is_Possibly_Unaligned_Object (Rhs)
+ then
Expand_Packed_Eq (N);
-- Where the component type is elementary we can use a block bit
-- comparison (if supported on the target) exception in the case
-- of floating-point (negative zero issues require element by
-- element comparison), and atomic types (where we must be sure
- -- to load elements independently).
+ -- to load elements independently) and possibly unaligned arrays.
elsif Is_Elementary_Type (Component_Type (Typl))
and then not Is_Floating_Point_Type (Component_Type (Typl))
and then not Is_Atomic (Component_Type (Typl))
+ and then not Is_Possibly_Unaligned_Object (Lhs)
+ and then not Is_Possibly_Unaligned_Object (Rhs)
and then Support_Composite_Compare_On_Target
then
null;
return;
end if;
- -- Case of array operand. If bit packed, handle it in Exp_Pakd
+ -- Case of array operand. If bit packed with a component size of 1,
+ -- handle it in Exp_Pakd if the operand is known to be aligned.
- if Is_Bit_Packed_Array (Typ) and then Component_Size (Typ) = 1 then
+ if Is_Bit_Packed_Array (Typ)
+ and then Component_Size (Typ) = 1
+ and then not Is_Possibly_Unaligned_Object (Right_Opnd (N))
+ then
Expand_Packed_Not (N);
return;
end if;
declare
New_Lhs : Node_Id;
New_Rhs : Node_Id;
+ Check : Node_Id;
begin
if First_Time then
New_Rhs := New_Copy_Tree (Rhs);
end if;
- Result :=
- Make_And_Then (Loc,
- Left_Opnd => Result,
- Right_Opnd =>
- Expand_Composite_Equality (Nod, Etype (C),
- Lhs =>
- Make_Selected_Component (Loc,
- Prefix => New_Lhs,
- Selector_Name => New_Reference_To (C, Loc)),
- Rhs =>
- Make_Selected_Component (Loc,
- Prefix => New_Rhs,
- Selector_Name => New_Reference_To (C, Loc)),
- Bodies => Bodies));
+ Check :=
+ Expand_Composite_Equality (Nod, Etype (C),
+ Lhs =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Lhs,
+ Selector_Name => New_Reference_To (C, Loc)),
+ Rhs =>
+ Make_Selected_Component (Loc,
+ Prefix => New_Rhs,
+ Selector_Name => New_Reference_To (C, Loc)),
+ Bodies => Bodies);
+
+ -- If some (sub)component is an unchecked_union, the whole
+ -- operation will raise program error.
+
+ if Nkind (Check) = N_Raise_Program_Error then
+ Result := Check;
+ Set_Etype (Result, Standard_Boolean);
+ exit;
+ else
+ Result :=
+ Make_And_Then (Loc,
+ Left_Opnd => Result,
+ Right_Opnd => Check);
+ end if;
end;
C := Suitable_Element (Next_Entity (C));
Obj_Tag :=
Make_Selected_Component (Loc,
Prefix => Relocate_Node (Left),
- Selector_Name => New_Reference_To (Tag_Component (Left_Type), Loc));
+ Selector_Name =>
+ New_Reference_To (First_Tag_Component (Left_Type), Loc));
if Is_Class_Wide_Type (Right_Type) then
return
Action => CW_Membership,
Args => New_List (
Obj_Tag,
- New_Reference_To (
- Access_Disp_Table (Root_Type (Right_Type)), Loc)));
+ New_Reference_To
+ (Node (First_Elmt
+ (Access_Disp_Table (Root_Type (Right_Type)))),
+ Loc)));
else
return
Make_Op_Eq (Loc,
Left_Opnd => Obj_Tag,
Right_Opnd =>
- New_Reference_To (Access_Disp_Table (Right_Type), Loc));
+ New_Reference_To
+ (Node (First_Elmt (Access_Disp_Table (Right_Type))), Loc));
end if;
end Tagged_Membership;