diff options
| -rw-r--r-- | gcc/ada/ChangeLog | 8 | ||||
| -rw-r--r-- | gcc/ada/gcc-interface/trans.c | 50 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 5 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/pack13.adb | 10 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/pack13.ads | 33 | ||||
| -rw-r--r-- | gcc/testsuite/gnat.dg/pack13_pkg.ads | 17 |
6 files changed, 122 insertions, 1 deletions
diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 0c0ed03..a03636a 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,5 +1,13 @@ 2009-04-20 Eric Botcazou <ebotcazou@adacore.com> + * gcc-interface/trans.c (unchecked_conversion_lhs_nop): New predicate. + (gnat_to_gnu) <N_Unchecked_Type_Conversion>: Return the expression + if the conversion is on the LHS of an assignment and a no-op. + <all> Do not convert the result to the result type if the Parent + node is such a conversion. + +2009-04-20 Eric Botcazou <ebotcazou@adacore.com> + * gcc-interface/ada-tree.h (DECL_HAS_REP_P): Delete. * gcc-interface/decl.c (gnat_to_gnu_entity): Add support for extension of types with unknown discriminants. diff --git a/gcc/ada/gcc-interface/trans.c b/gcc/ada/gcc-interface/trans.c index 0b29e33..9558302 100644 --- a/gcc/ada/gcc-interface/trans.c +++ b/gcc/ada/gcc-interface/trans.c @@ -3362,6 +3362,43 @@ Compilation_Unit_to_gnu (Node_Id gnat_node) invalidate_global_renaming_pointers (); } +/* Return whether GNAT_NODE, an unchecked type conversion, is on the LHS + of an assignment and a no-op as far as gigi is concerned. */ + +static bool +unchecked_conversion_lhs_nop (Node_Id gnat_node) +{ + Entity_Id from_type, to_type; + + /* The conversion must be on the LHS of an assignment. Otherwise, even + if the conversion was essentially a no-op, it could de facto ensure + type consistency and this should be preserved. */ + if (!(Nkind (Parent (gnat_node)) == N_Assignment_Statement + && Name (Parent (gnat_node)) == gnat_node)) + return false; + + from_type = Etype (Expression (gnat_node)); + + /* We're interested in artificial conversions generated by the front-end + to make private types explicit, e.g. in Expand_Assign_Array. */ + if (!Is_Private_Type (from_type)) + return false; + + from_type = Underlying_Type (from_type); + to_type = Etype (gnat_node); + + /* The direct conversion to the underlying type is a no-op. */ + if (to_type == from_type) + return true; + + /* For an array type, the conversion to the PAT is a no-op. */ + if (Ekind (from_type) == E_Array_Subtype + && to_type == Packed_Array_Type (from_type)) + return true; + + return false; +} + /* This function is the driver of the GNAT to GCC tree transformation process. It is the entry point of the tree transformer. GNAT_NODE is the root of some GNAT tree. Return the root of the corresponding GCC tree. @@ -4040,6 +4077,14 @@ gnat_to_gnu (Node_Id gnat_node) case N_Unchecked_Type_Conversion: gnu_result = gnat_to_gnu (Expression (gnat_node)); + + /* Skip further processing if the conversion is deemed a no-op. */ + if (unchecked_conversion_lhs_nop (gnat_node)) + { + gnu_result_type = TREE_TYPE (gnu_result); + break; + } + gnu_result_type = get_unpadded_type (Etype (gnat_node)); /* If the result is a pointer type, see if we are improperly @@ -5292,7 +5337,8 @@ gnat_to_gnu (Node_Id gnat_node) 1. If this is the Name of an assignment statement or a parameter of a procedure call, return the result almost unmodified since the RHS will have to be converted to our type in that case, unless - the result type has a simpler size. Similarly, don't convert + the result type has a simpler size. Likewise if there is just + a no-op unchecked conversion in-between. Similarly, don't convert integral types that are the operands of an unchecked conversion since we need to ignore those conversions (for 'Valid). @@ -5315,6 +5361,8 @@ gnat_to_gnu (Node_Id gnat_node) if (Present (Parent (gnat_node)) && ((Nkind (Parent (gnat_node)) == N_Assignment_Statement && Name (Parent (gnat_node)) == gnat_node) + || (Nkind (Parent (gnat_node)) == N_Unchecked_Type_Conversion + && unchecked_conversion_lhs_nop (Parent (gnat_node))) || (Nkind (Parent (gnat_node)) == N_Procedure_Call_Statement && Name (Parent (gnat_node)) != gnat_node) || Nkind (Parent (gnat_node)) == N_Parameter_Association diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 5a072fc..8f0516d 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,5 +1,10 @@ 2009-04-20 Eric Botcazou <ebotcazou@adacore.com> + * gnat.dg/pack13.ad[sb]: New test. + * gnat.dg/pack13_pkg.ads: New helper. + +2009-04-20 Eric Botcazou <ebotcazou@adacore.com> + * gnat.dg/discr11.ad[sb]: New test. * gnat.dg/discr11_pkg.ads: New helper. diff --git a/gcc/testsuite/gnat.dg/pack13.adb b/gcc/testsuite/gnat.dg/pack13.adb new file mode 100644 index 0000000..dd9cb09 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack13.adb @@ -0,0 +1,10 @@ +-- [ dg-do compile } + +package body Pack13 is + + procedure Set (Myself : Object_Ptr; The_Data : Thirty_Two_Bits.Object) is + begin + Myself.Something.Data_1 := The_Data; + end; + +end Pack13; diff --git a/gcc/testsuite/gnat.dg/pack13.ads b/gcc/testsuite/gnat.dg/pack13.ads new file mode 100644 index 0000000..1836311 --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack13.ads @@ -0,0 +1,33 @@ +with Pack13_Pkg; + +package Pack13 is + + package Four_Bits is new Pack13_Pkg (4); + package Thirty_Two_Bits is new Pack13_Pkg (32); + + type Object is private; + type Object_Ptr is access all Object; + + procedure Set (Myself : Object_Ptr; The_Data : Thirty_Two_Bits.Object); + +private + + type Some_Record is record + Data_1 : Thirty_Two_Bits.Object; + Data_2 : Thirty_Two_Bits.Object; + Small_Data : Four_Bits.Object; + end record; + for Some_Record use record + Data_1 at 0 range 0 .. 31; + Data_2 at 4 range 0 .. 31; + Small_Data at 8 range 0 .. 3; + end record; + + type Object is record + Something : Some_Record; + end record; + for Object use record + Something at 0 range 0 .. 67; + end record; + +end Pack13; diff --git a/gcc/testsuite/gnat.dg/pack13_pkg.ads b/gcc/testsuite/gnat.dg/pack13_pkg.ads new file mode 100644 index 0000000..afe8bec --- /dev/null +++ b/gcc/testsuite/gnat.dg/pack13_pkg.ads @@ -0,0 +1,17 @@ +generic + + Size : Positive; + +package Pack13_Pkg is + + type Object is private; + +private + + type Bit is range 0 .. 1; + for Bit'size use 1; + + type Object is array (1 .. Size) of Bit; + pragma Pack (Object); + +end Pack13_Pkg; |