diff options
Diffstat (limited to 'gcc/ada/exp_ch4.adb')
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 644 |
1 files changed, 614 insertions, 30 deletions
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index d1a7bbc..7f57b02 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -47,6 +47,7 @@ with Opt; use Opt; with Rtsfind; use Rtsfind; with Sem; use Sem; with Sem_Cat; use Sem_Cat; +with Sem_Ch3; use Sem_Ch3; with Sem_Ch13; use Sem_Ch13; with Sem_Eval; use Sem_Eval; with Sem_Res; use Sem_Res; @@ -154,6 +155,17 @@ package body Exp_Ch4 is -- for created object. If context is an access parameter, create a -- local access type to have a usable finalization list. + function Has_Inferable_Discriminants (N : Node_Id) return Boolean; + -- Ada 2005 (AI-216): A view of an Unchecked_Union object has inferable + -- discriminants if it has a constrained nominal type, unless the object + -- is a component of an enclosing Unchecked_Union object that is subject + -- to a per-object constraint and the enclosing object lacks inferable + -- discriminants. + -- + -- An expression of an Unchecked_Union type has inferable discriminants + -- if it is either a name of an object with inferable discriminants or a + -- qualified expression whose subtype mark denotes a constrained subtype. + procedure Insert_Dereference_Action (N : Node_Id); -- N is an expression whose type is an access. When the type of the -- associated storage pool is derived from Checked_Pool, generate a @@ -1581,6 +1593,123 @@ package body Exp_Ch4 is end; else + -- Comparison between Unchecked_Union components + + if Is_Unchecked_Union (Full_Type) then + declare + Lhs_Type : Node_Id := Full_Type; + Rhs_Type : Node_Id := Full_Type; + Lhs_Discr_Val : Node_Id; + Rhs_Discr_Val : Node_Id; + + begin + -- Lhs subtype + + if Nkind (Lhs) = N_Selected_Component then + Lhs_Type := Etype (Entity (Selector_Name (Lhs))); + end if; + + -- Rhs subtype + + if Nkind (Rhs) = N_Selected_Component then + Rhs_Type := Etype (Entity (Selector_Name (Rhs))); + end if; + + -- Lhs of the composite equality + + if Is_Constrained (Lhs_Type) then + + -- Since the enclosing record can never be an + -- Unchecked_Union (this code is executed for records + -- that do not have variants), we may reference its + -- discriminant(s). + + if Nkind (Lhs) = N_Selected_Component + and then Has_Per_Object_Constraint ( + Entity (Selector_Name (Lhs))) + then + Lhs_Discr_Val := + Make_Selected_Component (Loc, + Prefix => Prefix (Lhs), + Selector_Name => + New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (Lhs_Type), + Lhs_Type, + Stored_Constraint (Lhs_Type)))); + + else + Lhs_Discr_Val := New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (Lhs_Type), + Lhs_Type, + Stored_Constraint (Lhs_Type))); + + end if; + else + -- It is not possible to infer the discriminant since + -- the subtype is not constrained. + + Insert_Action (Nod, + 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); + end if; + + -- Rhs of the composite equality + + if Is_Constrained (Rhs_Type) then + if Nkind (Rhs) = N_Selected_Component + and then Has_Per_Object_Constraint ( + Entity (Selector_Name (Rhs))) + then + Rhs_Discr_Val := + Make_Selected_Component (Loc, + Prefix => Prefix (Rhs), + Selector_Name => + New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (Rhs_Type), + Rhs_Type, + Stored_Constraint (Rhs_Type)))); + + else + Rhs_Discr_Val := New_Copy ( + Get_Discriminant_Value ( + First_Discriminant (Rhs_Type), + Rhs_Type, + Stored_Constraint (Rhs_Type))); + + end if; + else + Insert_Action (Nod, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + return Empty; + end if; + + -- Call the TSS equality function with the inferred + -- discriminant values. + + return + Make_Function_Call (Loc, + Name => New_Reference_To (Eq_Op, Loc), + Parameter_Associations => New_List ( + Lhs, + Rhs, + Lhs_Discr_Val, + Rhs_Discr_Val)); + end; + end if; + + -- Shouldn't this be an else, we can't fall through + -- the above IF, right??? + return Make_Function_Call (Loc, Name => New_Reference_To (Eq_Op, Loc), @@ -2963,6 +3092,27 @@ package body Exp_Ch4 is Prefix => New_Reference_To (Typ, Loc)))); Analyze_And_Resolve (N, Rtyp); return; + + -- Ada 2005 (AI-216): Program_Error is raised when evaluating + -- a membership test if the subtype mark denotes a constrained + -- Unchecked_Union subtype and the expression lacks inferable + -- discriminants. + + elsif Is_Unchecked_Union (Base_Type (Typ)) + and then Is_Constrained (Typ) + and then not Has_Inferable_Discriminants (Lop) + then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + -- Prevent Gigi from generating incorrect code by rewriting + -- the test as a standard False. + + Rewrite (N, + New_Occurrence_Of (Standard_False, Loc)); + + return; end if; -- Here we have a non-scalar type @@ -3714,6 +3864,10 @@ package body Exp_Ch4 is -- build and analyze call, adding conversions if the operation is -- inherited. + function Has_Unconstrained_UU_Component (Typ : Node_Id) return Boolean; + -- Determines whether a type has a subcompoment of an unconstrained + -- Unchecked_Union subtype. Typ is a record type. + ------------------------- -- Build_Equality_Call -- ------------------------- @@ -3731,14 +3885,315 @@ package body Exp_Ch4 is R_Exp := OK_Convert_To (Op_Type, R_Exp); end if; - Rewrite (N, - Make_Function_Call (Loc, - Name => New_Reference_To (Eq, Loc), - Parameter_Associations => New_List (L_Exp, R_Exp))); + -- If we have an Unchecked_Union, we need to add the inferred + -- discriminant values as actuals in the function call. At this + -- point, the expansion has determined that both operands have + -- inferable discriminants. + + if Is_Unchecked_Union (Op_Type) then + declare + Lhs_Type : constant Node_Id := Etype (L_Exp); + Rhs_Type : constant Node_Id := Etype (R_Exp); + Lhs_Discr_Val : Node_Id; + Rhs_Discr_Val : Node_Id; + + begin + -- Per-object constrained selected components require special + -- attention. If the enclosing scope of the component is an + -- Unchecked_Union, we can not reference its discriminants + -- directly. This is why we use the two extra parameters of + -- the equality function of the enclosing Unchecked_Union. + + -- type UU_Type (Discr : Integer := 0) is + -- . . . + -- end record; + -- pragma Unchecked_Union (UU_Type); + + -- 1. Unchecked_Union enclosing record: + + -- type Enclosing_UU_Type (Discr : Integer := 0) is record + -- . . . + -- Comp : UU_Type (Discr); + -- . . . + -- end Enclosing_UU_Type; + -- pragma Unchecked_Union (Enclosing_UU_Type); + + -- Obj1 : Enclosing_UU_Type; + -- Obj2 : Enclosing_UU_Type (1); + + -- . . . Obj1 = Obj2 . . . + + -- Generated code: + + -- if not (uu_typeEQ (obj1.comp, obj2.comp, a, b)) then + + -- A and B are the formal parameters of the equality function + -- of Enclosing_UU_Type. The function always has two extra + -- formals to capture the inferred discriminant values. + + -- 2. Non-Unchecked_Union enclosing record: + + -- type + -- Enclosing_Non_UU_Type (Discr : Integer := 0) + -- is record + -- . . . + -- Comp : UU_Type (Discr); + -- . . . + -- end Enclosing_Non_UU_Type; + + -- Obj1 : Enclosing_Non_UU_Type; + -- Obj2 : Enclosing_Non_UU_Type (1); + + -- . . . Obj1 = Obj2 . . . + + -- Generated code: + + -- if not (uu_typeEQ (obj1.comp, obj2.comp, + -- obj1.discr, obj2.discr)) then + + -- In this case we can directly reference the discriminants of + -- the enclosing record. + + -- Lhs of equality + + if Nkind (Lhs) = N_Selected_Component + and then Has_Per_Object_Constraint ( + Entity (Selector_Name (Lhs))) + then + -- Enclosing record is an Unchecked_Union, use formal A + + if Is_Unchecked_Union (Scope + (Entity (Selector_Name (Lhs)))) + then + Lhs_Discr_Val := + Make_Identifier (Loc, + Chars => Name_A); + + -- Enclosing record is of a non-Unchecked_Union type, it is + -- possible to reference the discriminant. + + else + Lhs_Discr_Val := + Make_Selected_Component (Loc, + Prefix => Prefix (Lhs), + Selector_Name => + New_Copy (Get_Discriminant_Value ( + First_Discriminant (Lhs_Type), + Lhs_Type, + Stored_Constraint (Lhs_Type)))); + + end if; + + -- Comment needed here ??? + + else + -- Infer the discriminant value + + Lhs_Discr_Val := + New_Copy (Get_Discriminant_Value ( + First_Discriminant (Lhs_Type), + Lhs_Type, + Stored_Constraint (Lhs_Type))); + + end if; + + -- Rhs of equality + + if Nkind (Rhs) = N_Selected_Component + and then Has_Per_Object_Constraint ( + Entity (Selector_Name (Rhs))) + then + if Is_Unchecked_Union (Scope + (Entity (Selector_Name (Rhs)))) + then + Rhs_Discr_Val := + Make_Identifier (Loc, + Chars => Name_B); + + else + Rhs_Discr_Val := + Make_Selected_Component (Loc, + Prefix => Prefix (Rhs), + Selector_Name => + New_Copy (Get_Discriminant_Value ( + First_Discriminant (Rhs_Type), + Rhs_Type, + Stored_Constraint (Rhs_Type)))); + + end if; + else + Rhs_Discr_Val := + New_Copy (Get_Discriminant_Value ( + First_Discriminant (Rhs_Type), + Rhs_Type, + Stored_Constraint (Rhs_Type))); + + end if; + + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Eq, Loc), + Parameter_Associations => New_List ( + L_Exp, + R_Exp, + Lhs_Discr_Val, + Rhs_Discr_Val))); + end; + + -- Normal case, not an unchecked union + + else + Rewrite (N, + Make_Function_Call (Loc, + Name => New_Reference_To (Eq, Loc), + Parameter_Associations => New_List (L_Exp, R_Exp))); + end if; Analyze_And_Resolve (N, Standard_Boolean, Suppress => All_Checks); end Build_Equality_Call; + ------------------------------------ + -- Has_Unconstrained_UU_Component -- + ------------------------------------ + + function Has_Unconstrained_UU_Component + (Typ : Node_Id) return Boolean + is + Tdef : constant Node_Id := + Type_Definition (Declaration_Node (Typ)); + Clist : Node_Id; + Vpart : Node_Id; + + function Component_Is_Unconstrained_UU + (Comp : Node_Id) return Boolean; + -- Determines whether the subtype of the component is an + -- unconstrained Unchecked_Union. + + function Variant_Is_Unconstrained_UU + (Variant : Node_Id) return Boolean; + -- Determines whether a component of the variant has an unconstrained + -- Unchecked_Union subtype. + + ----------------------------------- + -- Component_Is_Unconstrained_UU -- + ----------------------------------- + + function Component_Is_Unconstrained_UU + (Comp : Node_Id) return Boolean + is + begin + if Nkind (Comp) /= N_Component_Declaration then + return False; + end if; + + declare + Sindic : constant Node_Id := + Subtype_Indication (Component_Definition (Comp)); + + begin + -- Unconstrained nominal type. In the case of a constraint + -- present, the node kind would have been N_Subtype_Indication. + + if Nkind (Sindic) = N_Identifier then + return Is_Unchecked_Union (Base_Type (Etype (Sindic))); + end if; + + return False; + end; + end Component_Is_Unconstrained_UU; + + --------------------------------- + -- Variant_Is_Unconstrained_UU -- + --------------------------------- + + function Variant_Is_Unconstrained_UU + (Variant : Node_Id) return Boolean + is + Clist : constant Node_Id := Component_List (Variant); + + begin + if Is_Empty_List (Component_Items (Clist)) then + return False; + end if; + + declare + Comp : Node_Id := First (Component_Items (Clist)); + + begin + while Present (Comp) loop + + -- One component is sufficent + + if Component_Is_Unconstrained_UU (Comp) then + return True; + end if; + + Next (Comp); + end loop; + end; + + -- None of the components withing the variant were of + -- unconstrained Unchecked_Union type. + + return False; + end Variant_Is_Unconstrained_UU; + + -- Start of processing for Has_Unconstrained_UU_Component + + begin + if Null_Present (Tdef) then + return False; + end if; + + Clist := Component_List (Tdef); + Vpart := Variant_Part (Clist); + + -- Inspect available components + + if Present (Component_Items (Clist)) then + declare + Comp : Node_Id := First (Component_Items (Clist)); + + begin + while Present (Comp) loop + + -- One component is sufficent + + if Component_Is_Unconstrained_UU (Comp) then + return True; + end if; + + Next (Comp); + end loop; + end; + end if; + + -- Inspect available components withing variants + + if Present (Vpart) then + declare + Variant : Node_Id := First (Variants (Vpart)); + + begin + while Present (Variant) loop + + -- One component within a variant is sufficent + + if Variant_Is_Unconstrained_UU (Variant) then + return True; + end if; + + Next (Variant); + end loop; + end; + end if; + + -- Neither the available components, nor the components inside the + -- variant parts were of an unconstrained Unchecked_Union subtype. + + return False; + end Has_Unconstrained_UU_Component; + -- Start of processing for Expand_N_Op_Eq begin @@ -3899,6 +4354,50 @@ package body Exp_Ch4 is Build_Equality_Call (Op_Name); + -- 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. + + elsif Has_Unconstrained_UU_Component (Typl) then + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + -- Prevent Gigi from generating incorrect code by rewriting the + -- equality as a standard False. + + Rewrite (N, + New_Occurrence_Of (Standard_False, Loc)); + + elsif Is_Unchecked_Union (Typl) then + + -- If we can infer the discriminants of the operands, we make a + -- call to the TSS equality function. + + if Has_Inferable_Discriminants (Lhs) + and then + Has_Inferable_Discriminants (Rhs) + then + Build_Equality_Call + (TSS (Root_Type (Typl), TSS_Composite_Equality)); + + else + -- Ada 2005 (AI-216): Program_Error is raised when evaluating + -- the predefined equality operator for an Unchecked_Union type + -- if either of the operands lack inferable discriminants. + + Insert_Action (N, + Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction)); + + -- Prevent Gigi from generating incorrect code by rewriting + -- the equality as a standard False. + + Rewrite (N, + New_Occurrence_Of (Standard_False, Loc)); + + end if; + -- If a type support function is present (for complex cases), use it elsif Present (TSS (Root_Type (Typl), TSS_Composite_Equality)) then @@ -6288,7 +6787,33 @@ package body Exp_Ch4 is -- assignment processing. elsif Is_Record_Type (Target_Type) then - Handle_Changed_Representation; + + -- Ada 2005 (AI-216): Program_Error is raised when converting from + -- a derived Unchecked_Union type to an unconstrained non-Unchecked_ + -- Union type if the operand lacks inferable discriminants. + + if Is_Derived_Type (Operand_Type) + and then Is_Unchecked_Union (Base_Type (Operand_Type)) + and then not Is_Constrained (Target_Type) + and then not Is_Unchecked_Union (Base_Type (Target_Type)) + and then not Has_Inferable_Discriminants (Operand) + then + -- To prevent Gigi from generating illegal code, we make a + -- Program_Error node, but we give it the target type of the + -- conversion. + + declare + PE : constant Node_Id := Make_Raise_Program_Error (Loc, + Reason => PE_Unchecked_Union_Restriction); + + begin + Set_Etype (PE, Target_Type); + Rewrite (N, PE); + + end; + else + Handle_Changed_Representation; + end if; -- Case of conversions of enumeration types @@ -6555,31 +7080,6 @@ package body Exp_Ch4 is -- Start of processing for Expand_Record_Equality begin - -- Special processing for the unchecked union case, which will occur - -- only in the context of tagged types and dynamic dispatching, since - -- other cases are handled statically. We return True, but insert a - -- raise Program_Error statement. - - if Is_Unchecked_Union (Typ) then - - -- If this is a component of an enclosing record, return the Raise - -- statement directly. - - if No (Parent (Lhs)) then - Result := - Make_Raise_Program_Error (Loc, - Reason => PE_Unchecked_Union_Restriction); - Set_Etype (Result, Standard_Boolean); - return Result; - - else - Insert_Action (Lhs, - Make_Raise_Program_Error (Loc, - Reason => PE_Unchecked_Union_Restriction)); - return New_Occurrence_Of (Standard_True, Loc); - end if; - end if; - -- Generates the following code: (assuming that Typ has one Discr and -- component C2 is also a record) @@ -6712,6 +7212,90 @@ package body Exp_Ch4 is return Find_Final_List (Owner); end Get_Allocator_Final_List; + --------------------------------- + -- Has_Inferable_Discriminants -- + --------------------------------- + + function Has_Inferable_Discriminants (N : Node_Id) return Boolean is + + function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean; + -- Determines whether the left-most prefix of a selected component is a + -- formal parameter in a subprogram. Assumes N is a selected component. + + -------------------------------- + -- Prefix_Is_Formal_Parameter -- + -------------------------------- + + function Prefix_Is_Formal_Parameter (N : Node_Id) return Boolean is + Sel_Comp : Node_Id := N; + + begin + -- Move to the left-most prefix by climbing up the tree + + while Present (Parent (Sel_Comp)) + and then Nkind (Parent (Sel_Comp)) = N_Selected_Component + loop + Sel_Comp := Parent (Sel_Comp); + end loop; + + return Ekind (Entity (Prefix (Sel_Comp))) in Formal_Kind; + end Prefix_Is_Formal_Parameter; + + -- Start of processing for Has_Inferable_Discriminants + + begin + -- For identifiers and indexed components, it is sufficent to have a + -- constrained Unchecked_Union nominal subtype. + + if Nkind (N) = N_Identifier + or else + Nkind (N) = N_Indexed_Component + then + return Is_Unchecked_Union (Base_Type (Etype (N))) + and then + Is_Constrained (Etype (N)); + + -- For selected components, the subtype of the selector must be a + -- constrained Unchecked_Union. If the component is subject to a + -- per-object constraint, then the enclosing object must have inferable + -- discriminants. + + elsif Nkind (N) = N_Selected_Component then + if Has_Per_Object_Constraint (Entity (Selector_Name (N))) then + + -- A small hack. If we have a per-object constrained selected + -- component of a formal parameter, return True since we do not + -- know the actual parameter association yet. + + if Prefix_Is_Formal_Parameter (N) then + return True; + end if; + + -- Otherwise, check the enclosing object and the selector + + return Has_Inferable_Discriminants (Prefix (N)) + and then + Has_Inferable_Discriminants (Selector_Name (N)); + end if; + + -- The call to Has_Inferable_Discriminants will determine whether + -- the selector has a constrained Unchecked_Union nominal type. + + return Has_Inferable_Discriminants (Selector_Name (N)); + + -- A qualified expression has inferable discriminants if its subtype + -- mark is a constrained Unchecked_Union subtype. + + elsif Nkind (N) = N_Qualified_Expression then + return Is_Unchecked_Union (Subtype_Mark (N)) + and then + Is_Constrained (Subtype_Mark (N)); + + end if; + + return False; + end Has_Inferable_Discriminants; + ------------------------------- -- Insert_Dereference_Action -- ------------------------------- |