From: Javier Miranda Date: Tue, 31 Oct 2006 17:54:34 +0000 (+0100) Subject: exp_ch4.adb (Expand_N_Type_Conversion): Handle missing interface type conversion. X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=20b5d666e7c8f05951fa54942a24174e600f8884;p=gcc.git exp_ch4.adb (Expand_N_Type_Conversion): Handle missing interface type conversion. 2006-10-31 Javier Miranda Ed Schonberg Bob Duff Gary Dismukes Robert Dewar * exp_ch4.adb (Expand_N_Type_Conversion): Handle missing interface type conversion. (Expand_N_In): Do validity checks on range (Expand_Selected_Component): Use updated for of Denotes_Discriminant. (Expand_N_Allocator): For "new T", if the object is constrained by discriminant defaults, allocate the right amount of memory, rather than the maximum for type T. (Expand_Allocator_Expression): Suppress the call to Remove_Side_Effects when the allocator is initialized by a build-in-place call, since the allocator is already rewritten as a reference to the function result, and this prevents an unwanted duplication of the function call. Add with and use of Exp_Ch6. (Expand_Allocator_Expresssion): Check for an allocator whose expression is a call to build-in-place function and apply Make_Build_In_Place_Call_In_Allocator to the call (for both tagged and untagged designated types). (Expand_N_Unchecked_Type_Conversion): Do not do integer literal optimization if source or target is biased. (Expand_N_Allocator): Add comments for case of an allocator within a function that returns an anonymous access type designating tasks. (Expand_N_Allocator): apply discriminant checks for access discriminants of anonymous access types (AI-402, AI-416) From-SVN: r118257 --- diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 9eaeda66c7c..a65809fb638 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -31,8 +31,10 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Aggr; use Exp_Aggr; with Exp_Ch3; use Exp_Ch3; +with Exp_Ch6; use Exp_Ch6; with Exp_Ch7; use Exp_Ch7; with Exp_Ch9; use Exp_Ch9; +with Exp_Disp; use Exp_Disp; with Exp_Fixd; use Exp_Fixd; with Exp_Pakd; use Exp_Pakd; with Exp_Tss; use Exp_Tss; @@ -192,7 +194,7 @@ package body Exp_Ch4 is -- this by using Convert_To_Actual_Subtype if necessary). procedure Rewrite_Comparison (N : Node_Id); - -- if N is the node for a comparison whose outcome can be determined at + -- If N is the node for a comparison whose outcome can be determined at -- compile time, then the node N can be rewritten with True or False. If -- the outcome cannot be determined at compile time, the call has no -- effect. If N is a type conversion, then this processing is applied to @@ -382,12 +384,28 @@ package body Exp_Ch4 is Aggr_In_Place : constant Boolean := Is_Delayed_Aggregate (Exp); + Call_In_Place : Boolean := False; + Tag_Assign : Node_Id; Tmp_Node : Node_Id; begin if Is_Tagged_Type (T) or else Controlled_Type (T) then + -- Ada 2005 (AI-318-02): If the initialization expression is a + -- call to a build-in-place function, then access to the allocated + -- object must be passed to the function. Currently we limit such + -- functions to those with constrained limited result subtypes, + -- but eventually we plan to expand the allowed forms of funtions + -- that are treated as build-in-place. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (Exp) + then + Make_Build_In_Place_Call_In_Allocator (N, Exp); + Call_In_Place := True; + end if; + -- Actions inserted before: -- Temp : constant ptr_T := new T'(Expression); -- Temp._tag := T'tag; @@ -397,7 +415,12 @@ package body Exp_Ch4 is -- We analyze by hand the new internal allocator to avoid -- any recursion and inappropriate call to Initialize - if not Aggr_In_Place then + -- We don't want to remove side effects when the expression must be + -- built in place. In the case of a build-in-place function call, + -- that could lead to a duplication of the call, which was already + -- substituted for the allocator. + + if not Aggr_In_Place and then not Call_In_Place then Remove_Side_Effects (Exp); end if; @@ -700,6 +723,18 @@ package body Exp_Ch4 is end; end if; + -- Ada 2005 (AI-318-02): If the initialization expression is a + -- call to a build-in-place function, then access to the allocated + -- object must be passed to the function. Currently we limit such + -- functions to those with constrained limited result subtypes, + -- but eventually we plan to expand the allowed forms of funtions + -- that are treated as build-in-place. + + if Ada_Version >= Ada_05 + and then Is_Build_In_Place_Function_Call (Exp) + then + Make_Build_In_Place_Call_In_Allocator (N, Exp); + end if; end if; exception @@ -2630,21 +2665,21 @@ package body Exp_Ch4 is Set_Assignment_OK (Arg1); Temp_Type := PtrT; - -- The initialization procedure expects a specific type. - -- if the context is access to class wide, indicate that - -- the object being allocated has the right specific type. + -- The initialization procedure expects a specific type. if + -- the context is access to class wide, indicate that the + -- object being allocated has the right specific type. if Is_Class_Wide_Type (Dtyp) then Arg1 := Unchecked_Convert_To (T, Arg1); end if; end if; - -- If designated type is a concurrent type or if it is a - -- private type whose definition is a concurrent type, - -- the first argument in the Init routine has to be - -- unchecked conversion to the corresponding record type. - -- If the designated type is a derived type, we also - -- convert the argument to its root type. + -- If designated type is a concurrent type or if it is private + -- type whose definition is a concurrent type, the first + -- argument in the Init routine has to be unchecked conversion + -- to the corresponding record type. If the designated type is + -- a derived type, we also convert the argument to its root + -- type. if Is_Concurrent_Type (T) then Arg1 := @@ -2671,29 +2706,31 @@ package body Exp_Ch4 is Args := New_List (Arg1); - -- For the task case, pass the Master_Id of the access type - -- as the value of the _Master parameter, and _Chain as the - -- value of the _Chain parameter (_Chain will be defined as - -- part of the generated code for the allocator). + -- For the task case, pass the Master_Id of the access type as + -- the value of the _Master parameter, and _Chain as the value + -- of the _Chain parameter (_Chain will be defined as part of + -- the generated code for the allocator). + + -- In Ada 2005, the context may be a function that returns an + -- anonymous access type. In that case the Master_Id has been + -- created when expanding the function declaration. if Has_Task (T) then if No (Master_Id (Base_Type (PtrT))) then - -- The designated type was an incomplete type, and - -- the access type did not get expanded. Salvage - -- it now. + -- The designated type was an incomplete type, and the + -- access type did not get expanded. Salvage it now. Expand_N_Full_Type_Declaration (Parent (Base_Type (PtrT))); end if; - -- If the context of the allocator is a declaration or - -- an assignment, we can generate a meaningful image for - -- it, even though subsequent assignments might remove - -- the connection between task and entity. We build this - -- image when the left-hand side is a simple variable, - -- a simple indexed assignment or a simple selected - -- component. + -- If the context of the allocator is a declaration or an + -- assignment, we can generate a meaningful image for it, + -- even though subsequent assignments might remove the + -- connection between task and entity. We build this image + -- when the left-hand side is a simple variable, a simple + -- indexed assignment or a simple selected component. if Nkind (Parent (N)) = N_Assignment_Statement then declare @@ -2745,26 +2782,60 @@ package body Exp_Ch4 is -- Add discriminants if discriminated type - if Has_Discriminants (T) then - Discr := First_Elmt (Discriminant_Constraint (T)); + declare + Dis : Boolean := False; + Typ : Entity_Id; - while Present (Discr) loop - Append (New_Copy_Tree (Elists.Node (Discr)), Args); - Next_Elmt (Discr); - end loop; + begin + if Has_Discriminants (T) then + Dis := True; + Typ := T; - elsif Is_Private_Type (T) - and then Present (Full_View (T)) - and then Has_Discriminants (Full_View (T)) - then - Discr := - First_Elmt (Discriminant_Constraint (Full_View (T))); + elsif Is_Private_Type (T) + and then Present (Full_View (T)) + and then Has_Discriminants (Full_View (T)) + then + Dis := True; + Typ := Full_View (T); + end if; - while Present (Discr) loop - Append (New_Copy_Tree (Elists.Node (Discr)), Args); - Next_Elmt (Discr); - end loop; - end if; + if Dis then + -- If the allocated object will be constrained by the + -- default values for discriminants, then build a + -- subtype with those defaults, and change the allocated + -- subtype to that. Note that this happens in fewer + -- cases in Ada 2005 (AI-363). + + if not Is_Constrained (Typ) + and then Present (Discriminant_Default_Value + (First_Discriminant (Typ))) + and then (Ada_Version < Ada_05 + or else not Has_Constrained_Partial_View (Typ)) + then + Typ := Build_Default_Subtype (Typ, N); + Set_Expression (N, New_Reference_To (Typ, Loc)); + end if; + + Discr := First_Elmt (Discriminant_Constraint (Typ)); + while Present (Discr) loop + Node := Elists.Node (Discr); + Append (New_Copy_Tree (Elists.Node (Discr)), Args); + + -- AI-416: when the discriminant constraint is an + -- anonymous access type make sure an accessibility + -- check is inserted if necessary (3.10.2(22.q/2)) + + if Ada_Version >= Ada_05 + and then + Ekind (Etype (Node)) = E_Anonymous_Access_Type + then + Apply_Accessibility_Check (Node, Typ); + end if; + + Next_Elmt (Discr); + end loop; + end if; + end; -- We set the allocator as analyzed so that when we analyze the -- expression actions node, we do not get an unwanted recursive @@ -2780,8 +2851,8 @@ package body Exp_Ch4 is -- Attach_To_Final_List (Finalizable (Temp.all)); -- Initialize (Finalizable (Temp.all)); - -- Here ptr_T is the pointer type for the allocator, and T - -- is the subtype of the allocator. + -- Here ptr_T is the pointer type for the allocator, and is the + -- subtype of the allocator. Temp_Decl := Make_Object_Declaration (Loc, @@ -2798,8 +2869,8 @@ package body Exp_Ch4 is Insert_Action (N, Temp_Decl, Suppress => All_Checks); - -- If the designated type is task type or contains tasks, - -- Create block to activate created tasks, and insert + -- If the designated type is a task type or contains tasks, + -- create block to activate created tasks, and insert -- declaration for Task_Image variable ahead of call. if Has_Task (T) then @@ -2899,8 +2970,8 @@ package body Exp_Ch4 is -- Expand_N_And_Then -- ----------------------- - -- Expand into conditional expression if Actions present, and also - -- deal with optimizing case of arguments being True or False. + -- Expand into conditional expression if Actions present, and also deal + -- with optimizing case of arguments being True or False. procedure Expand_N_And_Then (N : Node_Id) is Loc : constant Source_Ptr := Sloc (N); @@ -2935,9 +3006,9 @@ package body Exp_Ch4 is Adjust_Result_Type (N, Typ); return; - -- If left argument is False, change (False and then Right) to - -- False. In this case we can forget the actions associated with - -- Right, since they will never be executed. + -- If left argument is False, change (False and then Right) to False. + -- In this case we can forget the actions associated with Right, + -- since they will never be executed. elsif Entity (Left) = Standard_False then Kill_Dead_Code (Right); @@ -3134,6 +3205,13 @@ package body Exp_Ch4 is return; end if; + -- Do validity check on operands + + if Validity_Checks_On and Validity_Check_Operands then + Ensure_Valid (Left_Opnd (N)); + Validity_Check_Range (Right_Opnd (N)); + end if; + -- Case of explicit range if Nkind (Rop) = N_Range then @@ -3235,11 +3313,10 @@ package body Exp_Ch4 is if Is_Tagged_Type (Typ) then - -- No expansion will be performed when Java_VM, as the - -- JVM back end will handle the membership tests directly - -- (tags are not explicitly represented in Java objects, - -- so the normal tagged membership expansion is not what - -- we want). + -- No expansion will be performed when Java_VM, as the JVM back + -- end will handle the membership tests directly (tags are not + -- explicitly represented in Java objects, so the normal tagged + -- membership expansion is not what we want). if not Java_VM then Rewrite (N, Tagged_Membership (N)); @@ -3248,7 +3325,7 @@ package body Exp_Ch4 is return; - -- If type is scalar type, rewrite as x in t'first .. t'last + -- If type is scalar type, rewrite as x in t'first .. t'last. -- This reason we do this is that the bounds may have the wrong -- type if they come from the original type definition. @@ -6149,7 +6226,7 @@ package body Exp_Ch4 is if Denotes_Discriminant - (Node (Dcon), Check_Protected => True) + (Node (Dcon), Check_Concurrent => True) then exit Discr_Loop; @@ -6847,6 +6924,13 @@ package body Exp_Ch4 is Actual_Target_Type := Target_Type; end if; + -- Ada 2005 (AI-251): Handle interface type conversion + + if Is_Interface (Actual_Operand_Type) then + Expand_Interface_Conversion (N, Is_Static => False); + return; + end if; + if Is_Class_Wide_Type (Actual_Operand_Type) and then Root_Type (Actual_Operand_Type) /= Actual_Target_Type and then Is_Ancestor @@ -7242,8 +7326,14 @@ package body Exp_Ch4 is -- flag is set, since then the value may be outside the expected range. -- This happens in the Normalize_Scalars case. + -- We also skip this if either the target or operand type is biased + -- because in this case, the unchecked conversion is supposed to + -- preserve the bit pattern, not the integer value. + if Is_Integer_Type (Target_Type) + and then not Has_Biased_Representation (Target_Type) and then Is_Integer_Type (Operand_Type) + and then not Has_Biased_Representation (Operand_Type) and then Compile_Time_Known_Value (Operand) and then not Kill_Range_Check (N) then @@ -7692,17 +7782,17 @@ package body Exp_Ch4 is -- type elem is (<>); -- type index is (<>); -- type a is array (index range <>) of elem; - -- + -- function Gnnn (X : a; Y: a) return boolean is -- J : index := Y'first; - -- + -- begin -- if X'length = 0 then -- return false; - -- + -- elsif Y'length = 0 then -- return true; - -- + -- else -- for I in X'range loop -- if X (I) = Y (J) then @@ -7711,12 +7801,12 @@ package body Exp_Ch4 is -- else -- J := index'succ (J); -- end if; - -- + -- else -- return X (I) > Y (J); -- end if; -- end loop; - -- + -- return X'length > Y'length; -- end if; -- end Gnnn; @@ -8077,24 +8167,25 @@ package body Exp_Ch4 is begin if Nkind (N) = N_Type_Conversion then Rewrite_Comparison (Expression (N)); + return; elsif Nkind (N) not in N_Op_Compare then - null; + return; + end if; - else - declare - Typ : constant Entity_Id := Etype (N); - Op1 : constant Node_Id := Left_Opnd (N); - Op2 : constant Node_Id := Right_Opnd (N); + declare + Typ : constant Entity_Id := Etype (N); + Op1 : constant Node_Id := Left_Opnd (N); + Op2 : constant Node_Id := Right_Opnd (N); - Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2); - -- Res indicates if compare outcome can be compile time determined + Res : constant Compare_Result := Compile_Time_Compare (Op1, Op2); + -- Res indicates if compare outcome can be compile time determined - True_Result : Boolean; - False_Result : Boolean; + True_Result : Boolean; + False_Result : Boolean; - begin - case N_Op_Compare (Nkind (N)) is + begin + case N_Op_Compare (Nkind (N)) is when N_Op_Eq => True_Result := Res = EQ; False_Result := Res = LT or else Res = GT or else Res = NE; @@ -8142,24 +8233,23 @@ package body Exp_Ch4 is when N_Op_Ne => True_Result := Res = NE or else Res = GT or else Res = LT; False_Result := Res = EQ; - end case; + end case; - if True_Result then - Rewrite (N, - Convert_To (Typ, - New_Occurrence_Of (Standard_True, Sloc (N)))); - Analyze_And_Resolve (N, Typ); - Warn_On_Known_Condition (N); + if True_Result then + Rewrite (N, + Convert_To (Typ, + New_Occurrence_Of (Standard_True, Sloc (N)))); + Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); - elsif False_Result then - Rewrite (N, - Convert_To (Typ, - New_Occurrence_Of (Standard_False, Sloc (N)))); - Analyze_And_Resolve (N, Typ); - Warn_On_Known_Condition (N); - end if; - end; - end if; + elsif False_Result then + Rewrite (N, + Convert_To (Typ, + New_Occurrence_Of (Standard_False, Sloc (N)))); + Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); + end if; + end; end Rewrite_Comparison; ----------------------------