[PATCH 3/3] gdb: Handle dynamic properties with negative values

[Andrew Burgess <andrew.burgess@embecosm.com>]

When running a 32-bit inferior on a 64-bit platform, fetching dynamic
properties that are signed is not correctly sign extending the fetched
value from 32 to 64 bits.  As a result, for example, a Fortran array
with negative array bounds will appear to GDB to have large positive
array bounds.

gdb/Changelog:

	* dwarf2loc.h (dwarf2_evaluate_property): Add signed_p parameter.
	* dwarf2loc.c (dwarf2_evaluate_property): Add signed_p parameter,
	if this is true then sign extend the value before returning.
	* findvar.c (follow_static_link): Update call to
	dwarf2_evaluate_property.
	* gdbtypes.c (resolve_dynamic_range): Likewise.
	(resolve_dynamic_array): Likewise.
	(resolve_dynamic_type_internal): Likewise.

gdb/testsuite/ChangeLog:

	* gdb.fortran/vla-ptype.exp: Print array with negative bounds.
	* gdb.fortran/vla-sizeof.exp: Print the size of an array with
	negative bounds.
	* gdb.fortran/vla-value.exp: Print elements of an array with
	negative bounds.
	* gdb.fortran/vla.f90: Setup an array with negative bounds for
	testing.
---
 gdb/ChangeLog                            | 12 ++++++++++++
 gdb/dwarf2loc.c                          | 30 ++++++++++++++++++++++++------
 gdb/dwarf2loc.h                          |  7 ++++++-
 gdb/findvar.c                            |  2 +-
 gdb/gdbtypes.c                           | 12 ++++++------
 gdb/testsuite/ChangeLog                  | 11 +++++++++++
 gdb/testsuite/gdb.fortran/vla-ptype.exp  | 12 ++++++++++++
 gdb/testsuite/gdb.fortran/vla-sizeof.exp | 10 ++++++++++
 gdb/testsuite/gdb.fortran/vla-value.exp  | 27 +++++++++++++++++++++++++++
 gdb/testsuite/gdb.fortran/vla.f90        | 15 +++++++++++++++
 10 files changed, 124 insertions(+), 14 deletions(-)

diff --git a/gdb/dwarf2loc.c b/gdb/dwarf2loc.c
index 411bf2912b2..ee229ae6de3 100644
--- a/gdb/dwarf2loc.c
+++ b/gdb/dwarf2loc.c
@@ -2428,8 +2428,10 @@ bool
 dwarf2_evaluate_property (const struct dynamic_prop *prop,
 			  struct frame_info *frame,
 			  struct property_addr_info *addr_stack,
-			  CORE_ADDR *value)
+			  CORE_ADDR *value, bool signed_p)
 {
+  bool converted_p = false;
+
   if (prop == NULL)
     return false;
 
@@ -2453,7 +2455,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
 
 		*value = value_as_address (val);
 	      }
-	    return true;
+	    converted_p = true;
 	  }
       }
       break;
@@ -2475,7 +2477,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
 	    if (!value_optimized_out (val))
 	      {
 		*value = value_as_address (val);
-		return true;
+		converted_p = true;
 	      }
 	  }
       }
@@ -2483,7 +2485,8 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
 
     case PROP_CONST:
       *value = prop->data.const_val;
-      return true;
+      converted_p = true;
+      break;
 
     case PROP_ADDR_OFFSET:
       {
@@ -2505,11 +2508,26 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
 	  val = value_at (baton->offset_info.type,
 			  pinfo->addr + baton->offset_info.offset);
 	*value = value_as_address (val);
-	return true;
+	converted_p = true;
       }
+      break;
     }
 
-  return false;
+  if (converted_p && signed_p)
+    {
+      /* If we have a valid return candidate and it's value is signed,
+         we have to sign-extend the value because CORE_ADDR on 64bit
+         machine has 8 bytes but address size of an 32bit application
+	 is 4 bytes.  */
+      struct gdbarch * gdbarch = target_gdbarch ();
+      const int addr_bit = gdbarch_addr_bit (gdbarch);
+      const CORE_ADDR neg_mask = ((~0) <<  (addr_bit - 1));
+
+      /* Check if signed bit is set and sign-extend values.  */
+      if (*value & (neg_mask))
+	*value |= (neg_mask );
+    }
+  return converted_p;
 }
 
 /* See dwarf2loc.h.  */
diff --git a/gdb/dwarf2loc.h b/gdb/dwarf2loc.h
index ac1a771a9f3..7ebca31efc0 100644
--- a/gdb/dwarf2loc.h
+++ b/gdb/dwarf2loc.h
@@ -135,13 +135,18 @@ struct property_addr_info
    property. When evaluating a property that is not related to a type, it can
    be NULL.
 
+   SIGNED_P should be true if the property should be treated as a signed
+   value, and sign extended to the size of VALUE, or false to treat the
+   property as unsigned (for example, for address properties).
+
    Returns true if PROP could be converted and the static value is passed
    back into VALUE, otherwise returns false.  */
 
 bool dwarf2_evaluate_property (const struct dynamic_prop *prop,
 			       struct frame_info *frame,
 			       struct property_addr_info *addr_stack,
-			       CORE_ADDR *value);
+			       CORE_ADDR *value,
+			       bool signed_p);
 
 /* A helper for the compiler interface that compiles a single dynamic
    property to C code.
diff --git a/gdb/findvar.c b/gdb/findvar.c
index e89ee37ffc7..cefd0d0f2e3 100644
--- a/gdb/findvar.c
+++ b/gdb/findvar.c
@@ -433,7 +433,7 @@ follow_static_link (struct frame_info *frame,
 {
   CORE_ADDR upper_frame_base;
 
-  if (!dwarf2_evaluate_property (static_link, frame, NULL, &upper_frame_base))
+  if (!dwarf2_evaluate_property (static_link, frame, NULL, &upper_frame_base, false))
     return NULL;
 
   /* Now climb up the stack frame until we reach the frame we are interested
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index fe52a64f212..479d30d05d3 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1980,7 +1980,7 @@ resolve_dynamic_range (struct type *dyn_range_type,
   gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE);
 
   prop = &TYPE_RANGE_DATA (dyn_range_type)->low;
-  if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+  if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value, true))
     {
       low_bound.kind = PROP_CONST;
       low_bound.data.const_val = value;
@@ -1992,7 +1992,7 @@ resolve_dynamic_range (struct type *dyn_range_type,
     }
 
   prop = &TYPE_RANGE_DATA (dyn_range_type)->high;
-  if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+  if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value, true))
     {
       high_bound.kind = PROP_CONST;
       high_bound.data.const_val = value;
@@ -2043,13 +2043,13 @@ resolve_dynamic_array (struct type *type,
   /* Resolve allocated/associated here before creating a new array type, which
      will update the length of the array accordingly.  */
   prop = TYPE_ALLOCATED_PROP (type);
-  if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+  if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value, false))
     {
       TYPE_DYN_PROP_ADDR (prop) = value;
       TYPE_DYN_PROP_KIND (prop) = PROP_CONST;
     }
   prop = TYPE_ASSOCIATED_PROP (type);
-  if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+  if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value, false))
     {
       TYPE_DYN_PROP_ADDR (prop) = value;
       TYPE_DYN_PROP_KIND (prop) = PROP_CONST;
@@ -2065,7 +2065,7 @@ resolve_dynamic_array (struct type *type,
   prop = get_dyn_prop (DYN_PROP_BYTE_STRIDE, type);
   if (prop != NULL)
     {
-      if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+      if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value, true))
 	{
 	  remove_dyn_prop (DYN_PROP_BYTE_STRIDE, type);
 	  bit_stride = (unsigned int) (value * 8);
@@ -2282,7 +2282,7 @@ resolve_dynamic_type_internal (struct type *type,
   /* Resolve data_location attribute.  */
   prop = TYPE_DATA_LOCATION (resolved_type);
   if (prop != NULL
-      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+      && dwarf2_evaluate_property (prop, NULL, addr_stack, &value, false))
     {
       TYPE_DYN_PROP_ADDR (prop) = value;
       TYPE_DYN_PROP_KIND (prop) = PROP_CONST;
diff --git a/gdb/testsuite/gdb.fortran/vla-ptype.exp b/gdb/testsuite/gdb.fortran/vla-ptype.exp
index 0f4abb63757..7ad7ecdea65 100644
--- a/gdb/testsuite/gdb.fortran/vla-ptype.exp
+++ b/gdb/testsuite/gdb.fortran/vla-ptype.exp
@@ -98,3 +98,15 @@ gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not allocated"
 gdb_test "ptype vla2(5, 45, 20)" \
   "no such vector element \\\(vector not allocated\\\)" \
   "ptype vla2(5, 45, 20) not allocated"
+
+gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds-v1"]
+gdb_continue_to_breakpoint "vla1-neg-bounds-v1"
+gdb_test "ptype vla1" \
+    "type = $real, allocatable \\(-2:-1,-5:-2,-3:-1\\)" \
+    "ptype vla1 negative bounds"
+
+gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds-v2"]
+gdb_continue_to_breakpoint "vla1-neg-bounds-v2"
+gdb_test "ptype vla1" \
+    "type = $real, allocatable \\(-2:1,-5:2,-3:1\\)" \
+    "ptype vla1 negative lower bounds, positive upper bounds"
diff --git a/gdb/testsuite/gdb.fortran/vla-sizeof.exp b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
index 7f74a699d76..7527e0eb0b8 100644
--- a/gdb/testsuite/gdb.fortran/vla-sizeof.exp
+++ b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
@@ -44,3 +44,13 @@ gdb_test "print sizeof(pvla)" " = 0" "print sizeof non-associated pvla"
 gdb_breakpoint [gdb_get_line_number "pvla-associated"]
 gdb_continue_to_breakpoint "pvla-associated"
 gdb_test "print sizeof(pvla)" " = 4000" "print sizeof associated pvla"
+
+gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds-v1"]
+gdb_continue_to_breakpoint "vla1-neg-bounds-v1"
+gdb_test "print sizeof(vla1)" " = 96" \
+    "print sizeof vla1 negative bounds"
+
+gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds-v2"]
+gdb_continue_to_breakpoint "vla1-neg-bounds-v2"
+gdb_test "print sizeof(vla1)" " = 640" \
+    "print sizeof vla1 negative lower bounds, positive upper bounds"
diff --git a/gdb/testsuite/gdb.fortran/vla-value.exp b/gdb/testsuite/gdb.fortran/vla-value.exp
index be397fd95fb..3145d21c15c 100644
--- a/gdb/testsuite/gdb.fortran/vla-value.exp
+++ b/gdb/testsuite/gdb.fortran/vla-value.exp
@@ -161,3 +161,30 @@ gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
 gdb_continue_to_breakpoint "pvla-deassociated"
 gdb_test "print \$mypvar(1,3,8)" " = 1001" \
   "print \$mypvar(1,3,8) after deallocated"
+
+gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds-v1"]
+gdb_continue_to_breakpoint "vla1-neg-bounds-v1"
+with_test_prefix "negative bounds" {
+    gdb_test "print vla1(-2,-5,-3)" " = 1"
+    gdb_test "print vla1(-2,-3,-1)" " = -231"
+    gdb_test "print vla1(-3,-5,-3)" "no such vector element"
+    gdb_test "print vla1(-2,-6,-3)" "no such vector element"
+    gdb_test "print vla1(-2,-5,-4)" "no such vector element"
+    gdb_test "print vla1(0,-2,-1)" "no such vector element"
+    gdb_test "print vla1(-1,-1,-1)" "no such vector element"
+    gdb_test "print vla1(-1,-2,0)" "no such vector element"
+}
+
+gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds-v2"]
+gdb_continue_to_breakpoint "vla1-neg-bounds-v2"
+with_test_prefix "negative lower bounds, positive upper bounds" {
+    gdb_test "print vla1(-2,-5,-3)" " = 2"
+    gdb_test "print vla1(-2,-3,-1)" " = 2"
+    gdb_test "print vla1(-2,-4,-2)" " = -242"
+    gdb_test "print vla1(-3,-5,-3)" "no such vector element"
+    gdb_test "print vla1(-2,-6,-3)" "no such vector element"
+    gdb_test "print vla1(-2,-5,-4)" "no such vector element"
+    gdb_test "print vla1(2,2,1)" "no such vector element"
+    gdb_test "print vla1(1,3,1)" "no such vector element"
+    gdb_test "print vla1(1,2,2)" "no such vector element"
+}
diff --git a/gdb/testsuite/gdb.fortran/vla.f90 b/gdb/testsuite/gdb.fortran/vla.f90
index 5bc608744b3..0ccb5c90d93 100644
--- a/gdb/testsuite/gdb.fortran/vla.f90
+++ b/gdb/testsuite/gdb.fortran/vla.f90
@@ -54,4 +54,19 @@ program vla
 
   allocate (vla3 (2,2))               ! vla2-deallocated
   vla3(:,:) = 13
+
+  allocate (vla1 (-2:-1, -5:-2, -3:-1))
+  vla1(:, :, :) = 1
+  vla1(-2, -3, -1) = -231
+
+  deallocate (vla1)                   ! vla1-neg-bounds-v1
+  l = allocated(vla1)
+
+  allocate (vla1 (-2:1, -5:2, -3:1))
+  vla1(:, :, :) = 2
+  vla1(-2, -4, -2) = -242
+
+  deallocate (vla1)                   ! vla1-neg-bounds-v2
+  l = allocated(vla1)
+
 end program vla
-- 
2.14.5