From 58f1b7061e21da2b4abe14498bf79e8cad5450bf Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Sat, 27 Feb 2010 14:27:27 +0000 Subject: [PATCH] re PR ada/42253 (run time crash on null for thin pointers) PR ada/42253 * gcc-interface/utils2.c (build_binary_op) : Assert that fat pointer base types are variant of each other. Apply special treatment for null to fat pointer types in all cases. From-SVN: r157107 --- gcc/ada/ChangeLog | 7 +++ gcc/ada/gcc-interface/utils2.c | 60 ++++++++++--------- gcc/testsuite/ChangeLog | 7 +++ .../{thin_pointer.adb => thin_pointer1.adb} | 4 +- .../{thin_pointer.ads => thin_pointer1.ads} | 4 +- gcc/testsuite/gnat.dg/thin_pointer2.adb | 13 ++++ gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb | 18 ++++++ gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads | 9 +++ 8 files changed, 89 insertions(+), 33 deletions(-) rename gcc/testsuite/gnat.dg/{thin_pointer.adb => thin_pointer1.adb} (79%) rename gcc/testsuite/gnat.dg/{thin_pointer.ads => thin_pointer1.ads} (89%) create mode 100644 gcc/testsuite/gnat.dg/thin_pointer2.adb create mode 100644 gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb create mode 100644 gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a6aeb57ee88..b0d871b7bd4 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,10 @@ +2010-02-27 Eric Botcazou + + PR ada/42253 + * gcc-interface/utils2.c (build_binary_op) : Assert that fat + pointer base types are variant of each other. Apply special treatment + for null to fat pointer types in all cases. + 2010-01-28 Pascal Obry * s-win32.ads: Add some missing constants. diff --git a/gcc/ada/gcc-interface/utils2.c b/gcc/ada/gcc-interface/utils2.c index 7176740f453..3d6ac201107 100644 --- a/gcc/ada/gcc-interface/utils2.c +++ b/gcc/ada/gcc-interface/utils2.c @@ -834,26 +834,28 @@ build_binary_op (enum tree_code op_code, tree result_type, return result; } - /* Otherwise, the base types must be the same unless the objects are - fat pointers or records. If we have records, use the best type and - convert both operands to that type. */ + /* Otherwise, the base types must be the same, unless they are both fat + pointer types or record types. In the latter case, use the best type + and convert both operands to that type. */ if (left_base_type != right_base_type) { if (TYPE_IS_FAT_POINTER_P (left_base_type) - && TYPE_IS_FAT_POINTER_P (right_base_type) - && TYPE_MAIN_VARIANT (left_base_type) - == TYPE_MAIN_VARIANT (right_base_type)) - best_type = left_base_type; + && TYPE_IS_FAT_POINTER_P (right_base_type)) + { + gcc_assert (TYPE_MAIN_VARIANT (left_base_type) + == TYPE_MAIN_VARIANT (right_base_type)); + best_type = left_base_type; + } + else if (TREE_CODE (left_base_type) == RECORD_TYPE && TREE_CODE (right_base_type) == RECORD_TYPE) { - /* The only way these are permitted to be the same is if both - types have the same name. In that case, one of them must - not be self-referential. Use that one as the best type. - Even better is if one is of fixed size. */ + /* The only way this is permitted is if both types have the same + name. In that case, one of them must not be self-referential. + Use it as the best type. Even better with a fixed size. */ gcc_assert (TYPE_NAME (left_base_type) - && (TYPE_NAME (left_base_type) - == TYPE_NAME (right_base_type))); + && TYPE_NAME (left_base_type) + == TYPE_NAME (right_base_type)); if (TREE_CONSTANT (TYPE_SIZE (left_base_type))) best_type = left_base_type; @@ -866,34 +868,34 @@ build_binary_op (enum tree_code op_code, tree result_type, else gcc_unreachable (); } + else gcc_unreachable (); left_operand = convert (best_type, left_operand); right_operand = convert (best_type, right_operand); } - - /* If we are comparing a fat pointer against zero, we need to - just compare the data pointer. */ - else if (TYPE_IS_FAT_POINTER_P (left_base_type) - && TREE_CODE (right_operand) == CONSTRUCTOR - && integer_zerop (VEC_index (constructor_elt, - CONSTRUCTOR_ELTS (right_operand), - 0) - ->value)) - { - right_operand = build_component_ref (left_operand, NULL_TREE, - TYPE_FIELDS (left_base_type), - false); - left_operand = convert (TREE_TYPE (right_operand), - integer_zero_node); - } else { left_operand = convert (left_base_type, left_operand); right_operand = convert (right_base_type, right_operand); } + /* If we are comparing a fat pointer against zero, we just need to + compare the data pointer. */ + if (TYPE_IS_FAT_POINTER_P (left_base_type) + && TREE_CODE (right_operand) == CONSTRUCTOR + && integer_zerop (VEC_index (constructor_elt, + CONSTRUCTOR_ELTS (right_operand), + 0)->value)) + { + left_operand + = build_component_ref (left_operand, NULL_TREE, + TYPE_FIELDS (left_base_type), false); + right_operand + = convert (TREE_TYPE (left_operand), integer_zero_node); + } + modulus = NULL_TREE; break; diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 019a391918a..bc56a66c912 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2010-02-27 Eric Botcazou + + * gnat.dg/thin_pointer.ad[sb]: Rename into... + * gnat.dg/thin_pointer1.ad[sb]: ...this. + * gnat.dg/thin_pointer2.adb: New test. + * gnat.dg/thin_pointer2_pkg.ad[sb]: New helper. + 2010-02-26 Manuel López-Ibáñez PR c/20631 diff --git a/gcc/testsuite/gnat.dg/thin_pointer.adb b/gcc/testsuite/gnat.dg/thin_pointer1.adb similarity index 79% rename from gcc/testsuite/gnat.dg/thin_pointer.adb rename to gcc/testsuite/gnat.dg/thin_pointer1.adb index 1e3943f7a5b..8bc586ee475 100644 --- a/gcc/testsuite/gnat.dg/thin_pointer.adb +++ b/gcc/testsuite/gnat.dg/thin_pointer1.adb @@ -1,11 +1,11 @@ -- { dg-do compile } -- { dg-options "-O" } -package body Thin_Pointer is +package body Thin_Pointer1 is procedure Set_Buffer (AD : Buf_Ptr; Buffer : Stream_ptr) is begin AD.B.A := Buffer (Buffer'First)'Address; end Set_Buffer; -end Thin_Pointer; +end Thin_Pointer1; diff --git a/gcc/testsuite/gnat.dg/thin_pointer.ads b/gcc/testsuite/gnat.dg/thin_pointer1.ads similarity index 89% rename from gcc/testsuite/gnat.dg/thin_pointer.ads rename to gcc/testsuite/gnat.dg/thin_pointer1.ads index 6f528a51ed9..7332e84b74d 100644 --- a/gcc/testsuite/gnat.dg/thin_pointer.ads +++ b/gcc/testsuite/gnat.dg/thin_pointer1.ads @@ -1,6 +1,6 @@ with System; -package Thin_Pointer is +package Thin_Pointer1 is type Stream is array (Integer range <>) of Character; @@ -19,4 +19,4 @@ package Thin_Pointer is procedure Set_Buffer (AD : Buf_Ptr; Buffer : Stream_ptr); -end Thin_Pointer; +end Thin_Pointer1; diff --git a/gcc/testsuite/gnat.dg/thin_pointer2.adb b/gcc/testsuite/gnat.dg/thin_pointer2.adb new file mode 100644 index 00000000000..52c4dd6deab --- /dev/null +++ b/gcc/testsuite/gnat.dg/thin_pointer2.adb @@ -0,0 +1,13 @@ +-- PR ada/42253 +-- Testcase by Duncan Sands + +-- { dg-do run } + +with Thin_Pointer2_Pkg; use Thin_Pointer2_Pkg; + +procedure Thin_Pointer2 is +begin + if F /= '*' then + raise Program_Error; + end if; +end; diff --git a/gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb b/gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb new file mode 100644 index 00000000000..22500773cdc --- /dev/null +++ b/gcc/testsuite/gnat.dg/thin_pointer2_pkg.adb @@ -0,0 +1,18 @@ +package body Thin_Pointer2_Pkg is + + type SB is access constant String; + + function Inner (S : SB) return Character is + begin + if S /= null and then S'Length > 0 then + return S (S'First); + end if; + return '*'; + end; + + function F return Character is + begin + return Inner (SB (S)); + end; + +end Thin_Pointer2_Pkg; diff --git a/gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads b/gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads new file mode 100644 index 00000000000..f6752b0d726 --- /dev/null +++ b/gcc/testsuite/gnat.dg/thin_pointer2_pkg.ads @@ -0,0 +1,9 @@ +package Thin_Pointer2_Pkg is + + type SA is access String; + for SA'Size use Standard'Address_Size; + S : SA; + + function F return Character; + +end Thin_Pointer2_Pkg;