diff options
Diffstat (limited to 'gcc/ada/exp_ch4.adb')
| -rw-r--r-- | gcc/ada/exp_ch4.adb | 153 |
1 files changed, 133 insertions, 20 deletions
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index 22179e0b588..f8f2caa79b3 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -580,8 +580,7 @@ package body Exp_Ch4 is -- Allocate the object with no expression Node := Relocate_Node (N); - Set_Expression (Node, - New_Reference_To (Root_Type (Etype (Exp)), Loc)); + Set_Expression (Node, New_Reference_To (Etype (Exp), Loc)); -- Avoid its expansion to avoid generating a call to the default -- C++ constructor @@ -615,7 +614,7 @@ package body Exp_Ch4 is Id_Ref => Make_Explicit_Dereference (Loc, Prefix => New_Reference_To (Temp, Loc)), - Typ => Root_Type (Etype (Exp)), + Typ => Etype (Exp), Constructor_Ref => Exp)); end; @@ -3988,8 +3987,7 @@ package body Exp_Ch4 is else pragma Assert (Expr_Value_E (Right) = Standard_False); Remove_Side_Effects (Left); - Rewrite - (N, New_Occurrence_Of (Standard_False, Loc)); + Rewrite (N, New_Occurrence_Of (Standard_False, Loc)); end if; end if; @@ -4029,8 +4027,23 @@ package body Exp_Ch4 is -- and replace the conditional expression by a reference to Cnn + -- ??? Note: this expansion is wrong for limited types, since it does + -- a copy of a limited value. The proper fix would be to do the + -- following expansion: + + -- Cnn : access typ; + -- if cond then + -- <<then actions>> + -- Cnn := then-expr'Unrestricted_Access; + -- else + -- <<else actions>> + -- Cnn := else-expr'Unrestricted_Access; + -- end if; + + -- and replace the conditional expresion by a reference to Cnn.all ??? + if Present (Then_Actions (N)) or else Present (Else_Actions (N)) then - Cnn := Make_Defining_Identifier (Loc, New_Internal_Name ('C')); + Cnn := Make_Temporary (Loc, New_Internal_Name ('C'), N); New_If := Make_Implicit_If_Statement (N, @@ -4079,10 +4092,6 @@ package body Exp_Ch4 is Insert_Action (N, New_If); Analyze_And_Resolve (N, Typ); - - -- Link temporary to original expression, for Codepeer - - Set_Related_Expression (Cnn, Original_Node (N)); end if; end Expand_N_Conditional_Expression; @@ -4108,6 +4117,67 @@ package body Exp_Ch4 is Rop : constant Node_Id := Right_Opnd (N); Static : constant Boolean := Is_OK_Static_Expression (N); + procedure Expand_Set_Membership; + -- For each disjunct we create a simple equality or membership test. + -- The whole membership is rewritten as a short-circuit disjunction. + + --------------------------- + -- Expand_Set_Membership -- + --------------------------- + + procedure Expand_Set_Membership is + Alt : Node_Id; + Res : Node_Id; + + function Make_Cond (Alt : Node_Id) return Node_Id; + -- If the alternative is a subtype mark, create a simple membership + -- test. Otherwise create an equality test for it. + + --------------- + -- Make_Cond -- + --------------- + + function Make_Cond (Alt : Node_Id) return Node_Id is + Cond : Node_Id; + L : constant Node_Id := New_Copy (Lop); + R : constant Node_Id := Relocate_Node (Alt); + + begin + if Is_Entity_Name (Alt) + and then Is_Type (Entity (Alt)) + then + Cond := + Make_In (Sloc (Alt), + Left_Opnd => L, + Right_Opnd => R); + else + Cond := Make_Op_Eq (Sloc (Alt), + Left_Opnd => L, + Right_Opnd => R); + end if; + + return Cond; + end Make_Cond; + + -- Start of proessing for Expand_N_In + + begin + Alt := Last (Alternatives (N)); + Res := Make_Cond (Alt); + + Prev (Alt); + while Present (Alt) loop + Res := + Make_Or_Else (Sloc (Alt), + Left_Opnd => Make_Cond (Alt), + Right_Opnd => Res); + Prev (Alt); + end loop; + + Rewrite (N, Res); + Analyze_And_Resolve (N, Standard_Boolean); + end Expand_Set_Membership; + procedure Substitute_Valid_Check; -- Replaces node N by Lop'Valid. This is done when we have an explicit -- test for the left operand being in range of its subtype. @@ -4133,6 +4203,13 @@ package body Exp_Ch4 is -- Start of processing for Expand_N_In begin + + if Present (Alternatives (N)) then + Remove_Side_Effects (Lop); + Expand_Set_Membership; + return; + end if; + -- Check case of explicit test for an expression in range of its -- subtype. This is suspicious usage and we replace it with a 'Valid -- test and give a warning. @@ -4720,6 +4797,10 @@ package body Exp_Ch4 is Left_Opnd => Left_Opnd (N), Right_Opnd => Right_Opnd (N)))); + -- If this is a set membership, preserve list of alternatives + + Set_Alternatives (Right_Opnd (N), Alternatives (Original_Node (N))); + -- We want this to appear as coming from source if original does (see -- transformations in Expand_N_In). @@ -7519,6 +7600,11 @@ package body Exp_Ch4 is -- assignment to temporary. If there is no change of representation, -- then the conversion node is unchanged. + procedure Raise_Accessibility_Error; + -- Called when we know that an accessibility check will fail. Rewrites + -- node N to an appropriate raise statement and outputs warning msgs. + -- The Etype of the raise node is set to Target_Type. + procedure Real_Range_Check; -- Handles generation of range check for real target value @@ -7648,6 +7734,22 @@ package body Exp_Ch4 is end if; end Handle_Changed_Representation; + ------------------------------- + -- Raise_Accessibility_Error -- + ------------------------------- + + procedure Raise_Accessibility_Error is + begin + Rewrite (N, + Make_Raise_Program_Error (Sloc (N), + Reason => PE_Accessibility_Check_Failed)); + Set_Etype (N, Target_Type); + + Error_Msg_N ("?accessibility check failure", N); + Error_Msg_NE + ("\?& will be raised at run time", N, Standard_Program_Error); + end Raise_Accessibility_Error; + ---------------------- -- Real_Range_Check -- ---------------------- @@ -7810,9 +7912,14 @@ package body Exp_Ch4 is begin -- Nothing at all to do if conversion is to the identical type so remove - -- the conversion completely, it is useless. + -- the conversion completely, it is useless, except that it may carry + -- an Assignment_OK attribute, which must be propagated to the operand. if Operand_Type = Target_Type then + if Assignment_OK (N) then + Set_Assignment_OK (Operand); + end if; + Rewrite (N, Relocate_Node (Operand)); return; end if; @@ -7884,10 +7991,7 @@ package body Exp_Ch4 is and then Type_Access_Level (Operand_Type) > Type_Access_Level (Target_Type) then - Rewrite (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Target_Type); + Raise_Accessibility_Error; -- When the operand is a selected access discriminant the check needs -- to be made against the level of the object denoted by the prefix @@ -7901,11 +8005,7 @@ package body Exp_Ch4 is and then Object_Access_Level (Operand) > Type_Access_Level (Target_Type) then - Rewrite (N, - Make_Raise_Program_Error (Sloc (N), - Reason => PE_Accessibility_Check_Failed)); - Set_Etype (N, Target_Type); - + Raise_Accessibility_Error; return; end if; end if; @@ -8407,6 +8507,19 @@ package body Exp_Ch4 is Operand_Type : constant Entity_Id := Etype (Operand); begin + -- Nothing at all to do if conversion is to the identical type so remove + -- the conversion completely, it is useless, except that it may carry + -- an Assignment_OK indication which must be proprgated to the operand. + + if Operand_Type = Target_Type then + if Assignment_OK (N) then + Set_Assignment_OK (Operand); + end if; + + Rewrite (N, Relocate_Node (Operand)); + return; + end if; + -- If we have a conversion of a compile time known value to a target -- type and the value is in range of the target type, then we can simply -- replace the construct by an integer literal of the correct type. We |