diff options
Diffstat (limited to 'gcc/ada/exp_ch4.adb')
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 157 |
1 files changed, 94 insertions, 63 deletions
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index fd03a08b411..525bf67c2c3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -458,11 +458,13 @@ package body Exp_Ch4 is 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 @@ -487,12 +489,13 @@ package body Exp_Ch4 is 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); @@ -1063,10 +1066,16 @@ package body Exp_Ch4 is Test := Expand_Composite_Equality (Nod, Component_Type (Typ), L, R, Decls); - -- If some (sub)component is an unchecked_union, the whole - -- operation will raise program error. + -- 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 @@ -1160,6 +1169,7 @@ package body Exp_Ch4 is 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, @@ -1188,8 +1198,8 @@ package body Exp_Ch4 is 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 := @@ -1419,61 +1429,69 @@ package body Exp_Ch4 is 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; ------------------------------- @@ -4254,20 +4272,25 @@ package body Exp_Ch4 is 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; @@ -5278,9 +5301,13 @@ package body Exp_Ch4 is 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; @@ -7984,7 +8011,8 @@ package body Exp_Ch4 is 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 @@ -7992,14 +8020,17 @@ package body Exp_Ch4 is 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; |