[PATCH 00/11] Adds functionality and fixes some code

[Sebastian Basierski]

This series add few fixes to existing code
Also adds dynamic string support and extend
functionality of fortran arrays.
This series depends on previous one, starting with
[PATCH 1/7] DWARF: Don't add nameless modules to partial symbol table.

Bernhard Heckel (10):
Dwarf: Fix dynamic properties with neg. value.
Fortran: Fix negative bounds for dynamic allocated arrays.
Fortran: Resolve dynamic properties of pointer types.
Typeprint: Resolve any dynamic target type of a pointer.
Fortran: Typeprint, fix dangling types.
Resolve dynamic target types of pointers.
Fortran: Testsuite, add cyclic pointers.
fort_dyn_array: Fortran dynamic string support
fortran: Fix sizeof in case pointer is not associated and allocated.
fortran: Testsuite, add sizeof tests to indexed and sliced arrays.

Keven Boell (1):
vla: add stride support to fortran arrays.

gdb/NEWS | 2 +
gdb/c-valprint.c | 22 +++
gdb/dwarf2loc.c | 44 ++++-
gdb/dwarf2loc.h | 7 +
gdb/dwarf2read.c | 165 ++++++++++++++----
gdb/eval.c | 9 +
gdb/f-typeprint.c | 93 +++++-----
gdb/f-valprint.c | 8 +-
gdb/gdbtypes.c | 77 ++++++--
gdb/gdbtypes.h | 15 ++
gdb/testsuite/gdb.cp/vla-cxx.cc | 4 +
gdb/testsuite/gdb.cp/vla-cxx.exp | 11 ++
gdb/testsuite/gdb.fortran/oop-extend-type.exp | 2 +-
gdb/testsuite/gdb.fortran/pointers.exp | 165 ++++++++++++++++++
gdb/testsuite/gdb.fortran/pointers.f90 | 109 ++++++++++++
gdb/testsuite/gdb.fortran/print_type.exp | 100 +++++++++++
gdb/testsuite/gdb.fortran/vla-ptype.exp | 16 +-
gdb/testsuite/gdb.fortran/vla-sizeof.exp | 16 ++
gdb/testsuite/gdb.fortran/vla-stride.exp | 44 +++++
gdb/testsuite/gdb.fortran/vla-stride.f90 | 29 +++
gdb/testsuite/gdb.fortran/vla-strings.exp | 100 +++++++++++
gdb/testsuite/gdb.fortran/vla-strings.f90 | 39 +++++
gdb/testsuite/gdb.fortran/vla-type.exp | 7 +-
gdb/testsuite/gdb.fortran/vla-value.exp | 4 +-
gdb/testsuite/gdb.fortran/vla.f90 | 10 ++
gdb/testsuite/gdb.mi/mi-vla-fortran.exp | 8 +-
gdb/typeprint.c | 17 ++
gdb/valarith.c | 10 +-
gdb/valops.c | 16 +-
gdb/valprint.c | 6 -
30 files changed, 1033 insertions(+), 122 deletions(-)
create mode 100644 gdb/testsuite/gdb.fortran/pointers.exp
create mode 100644 gdb/testsuite/gdb.fortran/pointers.f90
create mode 100755 gdb/testsuite/gdb.fortran/print_type.exp
create mode 100644 gdb/testsuite/gdb.fortran/vla-stride.exp
create mode 100644 gdb/testsuite/gdb.fortran/vla-stride.f90
create mode 100644 gdb/testsuite/gdb.fortran/vla-strings.exp
create mode 100644 gdb/testsuite/gdb.fortran/vla-strings.f90

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

Evaluating of neg. value of 32bit inferiours running on 64bit plattform
causes issues because of the missing sign bits.

Bernhard Heckel <***@intel.com>

gdb/Changelog
* dwarf2loc.h: Declare
* dwarf2loc.c (dwarf2_evaluate_property_signed): New.
(dwarf2_evaluate_property): Delegate tasks to
dwarf2_evaluate_property_signed.
---
gdb/dwarf2loc.c | 44 +++++++++++++++++++++++++++++++++++---------
gdb/dwarf2loc.h | 7 +++++++
2 files changed, 42 insertions(+), 9 deletions(-)

diff --git a/gdb/dwarf2loc.c b/gdb/dwarf2loc.c
index ee6a8e277c..c94bdc60f2 100644
--- a/gdb/dwarf2loc.c
+++ b/gdb/dwarf2loc.c
@@ -2659,11 +2659,13 @@ dwarf2_locexpr_baton_eval (const struct dwarf2_locexpr_baton *dlbaton,
/* See dwarf2loc.h. */

int
-dwarf2_evaluate_property (const struct dynamic_prop *prop,
- struct frame_info *frame,
- struct property_addr_info *addr_stack,
- CORE_ADDR *value)
+dwarf2_evaluate_property_signed (const struct dynamic_prop *prop,
+ struct frame_info *frame,
+ struct property_addr_info *addr_stack,
+ CORE_ADDR *value, int is_signed)
{
+ int rc = 0;
+
if (prop == NULL)
return 0;

@@ -2687,7 +2689,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,

*value = value_as_address (val);
}
- return 1;
+ rc = 1;
}
}
break;
@@ -2709,7 +2711,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,
if (!value_optimized_out (val))
{
*value = value_as_address (val);
- return 1;
+ rc = 1;
}
}
}
@@ -2717,7 +2719,8 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop,

case PROP_CONST:
*value = prop->data.const_val;
- return 1;
+ rc = 1;
+ break;

case PROP_ADDR_OFFSET:
{
@@ -2739,11 +2742,34 @@ 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 1;
+ rc = 1;
}
+ break;
}

- return 0;
+ if (rc == 1 && is_signed == 1)
+ {
+ /* 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 rc;
+}
+
+int
+dwarf2_evaluate_property (const struct dynamic_prop *prop,
+ struct frame_info *frame,
+ struct property_addr_info *addr_stack,
+ CORE_ADDR *value)
+{
+ return dwarf2_evaluate_property_signed (prop, frame, addr_stack, value, 0);
}

/* See dwarf2loc.h. */
diff --git a/gdb/dwarf2loc.h b/gdb/dwarf2loc.h
index d7a56db05d..408e1904cd 100644
--- a/gdb/dwarf2loc.h
+++ b/gdb/dwarf2loc.h
@@ -143,6 +143,13 @@ int dwarf2_evaluate_property (const struct dynamic_prop *prop,
struct property_addr_info *addr_stack,
CORE_ADDR *value);

+int dwarf2_evaluate_property_signed (const struct dynamic_prop *prop,
+ struct frame_info *frame,
+ struct property_addr_info *addr_stack,
+ CORE_ADDR *value,
+ int is_signed);
+
+
/* A helper for the compiler interface that compiles a single dynamic
property to C code.

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

Fortran arrays might have negative bounds.
Take this into consideration when evaluating
dynamic bound properties.

Bernhard Heckel <***@intel.com>

gdb/Changelog:
* gdbtypes.c (resolve_dynamic_range):
Call dwarf2_evaluate_property_signed to resolve dynamic bounds.

gdb/Testsuite/Changelog:
* gdb.fortran/vla.f90: Extend by an array with negative bounds.
* gdb/testsuite/gdb.fortran/vla-sizeof.exp: Test array with negative bounds.
* gdb/testsuite/gdb.fortran/vla-ptype.exp: Test array with negative bounds.
---
gdb/gdbtypes.c | 4 ++--
gdb/testsuite/gdb.fortran/vla-ptype.exp | 4 ++++
gdb/testsuite/gdb.fortran/vla-sizeof.exp | 4 ++++
gdb/testsuite/gdb.fortran/vla.f90 | 10 ++++++++++
4 files changed, 20 insertions(+), 2 deletions(-)

diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 9e87b8f4c5..8adf899f9a 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1995,7 +1995,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_signed (prop, NULL, addr_stack, &value, 1))
{
low_bound.kind = PROP_CONST;
low_bound.data.const_val = value;
@@ -2007,7 +2007,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_signed (prop, NULL, addr_stack, &value, 1))
{
high_bound.kind = PROP_CONST;
high_bound.data.const_val = value;
diff --git a/gdb/testsuite/gdb.fortran/vla-ptype.exp b/gdb/testsuite/gdb.fortran/vla-ptype.exp
index 5f367348b0..5351a0aa2e 100644
--- a/gdb/testsuite/gdb.fortran/vla-ptype.exp
+++ b/gdb/testsuite/gdb.fortran/vla-ptype.exp
@@ -98,3 +98,7 @@ 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"]
+gdb_continue_to_breakpoint "vla1-neg-bounds"
+gdb_test "ptype vla1" "type = $real \\(-2:1,-5:4,-3:-1\\)" "ptype vla1 negative bounds"
diff --git a/gdb/testsuite/gdb.fortran/vla-sizeof.exp b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
index 3113983ba4..83bc849619 100644
--- a/gdb/testsuite/gdb.fortran/vla-sizeof.exp
+++ b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
@@ -44,3 +44,7 @@ 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"]
+gdb_continue_to_breakpoint "vla1-neg-bounds"
+gdb_test "print sizeof(vla1)" " = 480" "print sizeof vla1 negative bounds"
diff --git a/gdb/testsuite/gdb.fortran/vla.f90 b/gdb/testsuite/gdb.fortran/vla.f90
index 508290a36e..d87f59b92b 100644
--- a/gdb/testsuite/gdb.fortran/vla.f90
+++ b/gdb/testsuite/gdb.fortran/vla.f90
@@ -54,4 +54,14 @@ program vla

allocate (vla3 (2,2)) ! vla2-deallocated
vla3(:,:) = 13
+
+ allocate (vla1 (-2:1, -5:4, -3:-1))
+ l = allocated(vla1)
+
+ vla1(:, :, :) = 1
+ vla1(-2, -3, -1) = -231
+
+ deallocate (vla1) ! vla1-neg-bounds
+ l = allocated(vla1)
+
end program vla

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

In Fortran a pointer may have a dynamic associated property.

2016-07-08 Bernhard Heckel <***@intel.com>

gdb/Changelog:
* gdbtypes.c (is_dynamic_type_internal): Resolve pointer types.
(resolve_dynamic_pointer): New.
---
gdb/gdbtypes.c | 29 ++++++++++++++++++++++++++++-
1 file changed, 28 insertions(+), 1 deletion(-)

diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 6730ae28e5..228b680a26 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1913,7 +1913,8 @@ is_dynamic_type_internal (struct type *type, int top_level)
type = check_typedef (type);

/* We only want to recognize references at the outermost level. */
- if (top_level && TYPE_CODE (type) == TYPE_CODE_REF)
+ if (top_level &&
+ (TYPE_CODE (type) == TYPE_CODE_REF || TYPE_CODE (type) == TYPE_CODE_PTR))
type = check_typedef (TYPE_TARGET_TYPE (type));

/* Types that have a dynamic TYPE_DATA_LOCATION are considered
@@ -2248,6 +2249,28 @@ resolve_dynamic_struct (struct type *type,
return resolved_type;
}

+/* Worker for pointer types. */
+
+static struct type *
+resolve_dynamic_pointer (struct type *type,
+ struct property_addr_info *addr_stack)
+{
+ struct dynamic_prop *prop;
+ CORE_ADDR value;
+
+ type = copy_type (type);
+
+ /* Resolve associated property. */
+ prop = TYPE_ASSOCIATED_PROP (type);
+ if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+ {
+ TYPE_DYN_PROP_ADDR (prop) = value;
+ TYPE_DYN_PROP_KIND (prop) = PROP_CONST;
+ }
+
+ return type;
+}
+
/* Worker for resolved_dynamic_type. */

static struct type *
@@ -2296,6 +2319,10 @@ resolve_dynamic_type_internal (struct type *type,
break;
}

+ case TYPE_CODE_PTR:
+ resolved_type = resolve_dynamic_pointer (type, addr_stack);
+ break;
+
case TYPE_CODE_ARRAY:
resolved_type = resolve_dynamic_array (type, addr_stack);
break;

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

Before continuing with language specific type printing
we have to resolve the target type of a pointer
as we might wanna print more details of the target
like the dimension of an array. We have to resolve it here
as we don't have any address information later on.

2016-07-08 Bernhard Heckel <***@intel.com>

gdb/Changelog:
* typeprint.c (whatis_exp): Resolve dynamic target type
of pointers.

gdb/Testsuite/Changelog:
* gdb.cp/vla-cxx.cc: Added pointer to dynamic type.
* gdb.cp/vla-cxx.exp: Test pointer to dynamic type.
---
gdb/testsuite/gdb.cp/vla-cxx.cc | 4 ++++
gdb/testsuite/gdb.cp/vla-cxx.exp | 5 +++++
gdb/typeprint.c | 17 +++++++++++++++++
3 files changed, 26 insertions(+)

diff --git a/gdb/testsuite/gdb.cp/vla-cxx.cc b/gdb/testsuite/gdb.cp/vla-cxx.cc
index 1b5b27bf3d..fce8876e7d 100644
--- a/gdb/testsuite/gdb.cp/vla-cxx.cc
+++ b/gdb/testsuite/gdb.cp/vla-cxx.cc
@@ -40,6 +40,10 @@ int main(int argc, char **argv)
typedef typeof (vla) &vlareftypedef;
vlareftypedef vlaref2 (vla);
container c;
+ typeof (vla) *ptr = nullptr;
+
+ // Before pointer assignment
+ ptr = &vla;

for (int i = 0; i < z; ++i)
vla[i] = 5 + 2 * i;
diff --git a/gdb/testsuite/gdb.cp/vla-cxx.exp b/gdb/testsuite/gdb.cp/vla-cxx.exp
index ac87499d49..2cf2d9868f 100644
--- a/gdb/testsuite/gdb.cp/vla-cxx.exp
+++ b/gdb/testsuite/gdb.cp/vla-cxx.exp
@@ -23,6 +23,10 @@ if ![runto_main] {
return -1
}

+gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
+gdb_continue_to_breakpoint "Before pointer assignment"
+gdb_test "ptype ptr" "int \\(\\*\\)\\\[variable length\\\]" "ptype ptr, Before pointer assignment"
+
gdb_breakpoint [gdb_get_line_number "vlas_filled"]
gdb_continue_to_breakpoint "vlas_filled"

@@ -33,3 +37,4 @@ gdb_test "print vlaref" " = \\(int \\(&\\)\\\[3\\\]\\) @$hex: \\{5, 7, 9\\}"
# bug being tested, it's better not to depend on the exact spelling.
gdb_test "print vlaref2" " = \\(.*\\) @$hex: \\{5, 7, 9\\}"
gdb_test "print c" " = \\{e = \\{c = @$hex\\}\\}"
+gdb_test "ptype ptr" "int \\(\\*\\)\\\[3\\\]"
diff --git a/gdb/typeprint.c b/gdb/typeprint.c
index 393d825fe5..de8fbd7652 100644
--- a/gdb/typeprint.c
+++ b/gdb/typeprint.c
@@ -589,6 +589,23 @@ whatis_exp (const char *exp, int show)
printf_filtered (" */\n");
}

+ /* Resolve any dynamic target type, as we might print
+ additional information about the target.
+ For example, in Fortran and C we are printing the dimension of the
+ dynamic array the pointer is pointing to. */
+ if (TYPE_CODE (type) == TYPE_CODE_PTR && is_dynamic_type (type))
+ {
+ CORE_ADDR addr;
+ if (TYPE_DATA_LOCATION (TYPE_TARGET_TYPE(type)) != nullptr)
+ addr = value_address (val);
+ else
+ addr = value_as_address (val);
+
+ if (addr != 0 && !type_not_associated (type))
+ TYPE_TARGET_TYPE (type) =
+ resolve_dynamic_type (TYPE_TARGET_TYPE (type), nullptr, addr);
+ }
+
LA_PRINT_TYPE (type, "", gdb_stdout, show, 0, &flags);
printf_filtered ("\n");
}

[Sebastian Basierski]

From: Keven Boell <***@intel.com>

2014-05-28 Bernhard Heckel <***@intel.com>
Sanimir Agovic <***@intel.com>
Keven Boell <***@intel.com>

gdb/Changelog:
* dwarf2read.c (read_subrange_type): Read dynamic
stride attributes.
* gdbtypes.c (create_array_type_with_stride): Add
stride support
(create_range_type): Add stride parameter.
(create_static_range_type): Pass default stride
parameter.
(resolve_dynamic_range): Evaluate stride baton.
* gdbtypes.h (TYPE_BYTE_STRIDE): New macro.
(TYPE_BYTE_STRIDE_BLOCK): New macro.
(TYPE_BYTE_STRIDE_LOCLIST): New macro.
(TYPE_BYTE_STRIDE_KIND): New macro.
* valarith.c (value_subscripted_rvalue): Use stride.

gdb/testsuite/Changelog:
* vla-stride.exp: New file.
* vla-stride.f90: New file.
---
gdb/dwarf2read.c | 14 ++++++--
gdb/f-valprint.c | 8 ++++-
gdb/gdbtypes.c | 29 ++++++++++++----
gdb/gdbtypes.h | 15 ++++++++
gdb/testsuite/gdb.fortran/vla-stride.exp | 44 ++++++++++++++++++++++++
gdb/testsuite/gdb.fortran/vla-stride.f90 | 29 ++++++++++++++++
gdb/valarith.c | 10 ++++--
7 files changed, 138 insertions(+), 11 deletions(-)
create mode 100644 gdb/testsuite/gdb.fortran/vla-stride.exp
create mode 100644 gdb/testsuite/gdb.fortran/vla-stride.f90

diff --git a/gdb/dwarf2read.c b/gdb/dwarf2read.c
index 78f96ea0d1..902aad3fbc 100644
--- a/gdb/dwarf2read.c
+++ b/gdb/dwarf2read.c
@@ -17841,7 +17841,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
struct type *base_type, *orig_base_type;
struct type *range_type;
struct attribute *attr;
- struct dynamic_prop low, high;
+ struct dynamic_prop low, high, stride;
int low_default_is_valid;
int high_bound_is_count = 0;
const char *name;
@@ -17861,7 +17861,9 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)

low.kind = PROP_CONST;
high.kind = PROP_CONST;
+ stride.kind = PROP_CONST;
high.data.const_val = 0;
+ stride.data.const_val = 0;

/* Set LOW_DEFAULT_IS_VALID if current language and DWARF version allow
omitting DW_AT_lower_bound. */
@@ -17894,6 +17896,14 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
break;
}

+ attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
+ if (attr)
+ if (!attr_to_dynamic_prop (attr, die, cu, &stride))
+ complaint (_("Missing DW_AT_byte_stride "
+ "- DIE at 0x%s [in module %s]"),
+ sect_offset_str (die->sect_off),
+ objfile_name (cu->per_cu->dwarf2_per_objfile->objfile));
+
attr = dwarf2_attr (die, DW_AT_lower_bound, cu);
if (attr)
attr_to_dynamic_prop (attr, die, cu, &low);
@@ -17986,7 +17996,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
&& !TYPE_UNSIGNED (base_type) && (high.data.const_val & negative_mask))
high.data.const_val |= negative_mask;

- range_type = create_range_type (NULL, orig_base_type, &low, &high);
+ range_type = create_range_type (NULL, orig_base_type, &low, &high, &stride);

if (high_bound_is_count)
TYPE_RANGE_DATA (range_type)->flag_upper_bound_is_count = 1;
diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c
index 903f2af638..b4067a8460 100644
--- a/gdb/f-valprint.c
+++ b/gdb/f-valprint.c
@@ -119,8 +119,14 @@ f77_print_array_1 (int nss, int ndimensions, struct type *type,

if (nss != ndimensions)
{
- size_t dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));
+ size_t dim_size;
size_t offs = 0;
+ LONGEST byte_stride = abs (TYPE_BYTE_STRIDE (range_type));
+
+ if (byte_stride)
+ dim_size = byte_stride;
+ else
+ dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));

for (i = lowerbound;
(i < upperbound + 1 && (*elts) < options->print_max);
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 8adf899f9a..6730ae28e5 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -911,7 +911,8 @@ operator== (const range_bounds &l, const range_bounds &r)
struct type *
create_range_type (struct type *result_type, struct type *index_type,
const struct dynamic_prop *low_bound,
- const struct dynamic_prop *high_bound)
+ const struct dynamic_prop *high_bound,
+ const struct dynamic_prop *stride)
{
if (result_type == NULL)
result_type = alloc_type_copy (index_type);
@@ -926,6 +927,7 @@ create_range_type (struct type *result_type, struct type *index_type,
TYPE_ZALLOC (result_type, sizeof (struct range_bounds));
TYPE_RANGE_DATA (result_type)->low = *low_bound;
TYPE_RANGE_DATA (result_type)->high = *high_bound;
+ TYPE_RANGE_DATA (result_type)->stride = *stride;

if (low_bound->kind == PROP_CONST && low_bound->data.const_val >= 0)
TYPE_UNSIGNED (result_type) = 1;
@@ -954,7 +956,7 @@ struct type *
create_static_range_type (struct type *result_type, struct type *index_type,
LONGEST low_bound, LONGEST high_bound)
{
- struct dynamic_prop low, high;
+ struct dynamic_prop low, high, stride;

low.kind = PROP_CONST;
low.data.const_val = low_bound;
@@ -962,7 +964,11 @@ create_static_range_type (struct type *result_type, struct type *index_type,
high.kind = PROP_CONST;
high.data.const_val = high_bound;

- result_type = create_range_type (result_type, index_type, &low, &high);
+ stride.kind = PROP_CONST;
+ stride.data.const_val = 0;
+
+ result_type = create_range_type (result_type, index_type,
+ &low, &high, &stride);

return result_type;
}
@@ -1180,16 +1186,20 @@ create_array_type_with_stride (struct type *result_type,
&& (!type_not_associated (result_type)
&& !type_not_allocated (result_type)))
{
- LONGEST low_bound, high_bound;
+ LONGEST low_bound, high_bound, byte_stride;

if (get_discrete_bounds (range_type, &low_bound, &high_bound) < 0)
low_bound = high_bound = 0;
element_type = check_typedef (element_type);
+ byte_stride = abs (TYPE_BYTE_STRIDE (range_type));
+
/* Be careful when setting the array length. Ada arrays can be
empty arrays with the high_bound being smaller than the low_bound.
In such cases, the array length should be zero. */
if (high_bound < low_bound)
TYPE_LENGTH (result_type) = 0;
+ else if (byte_stride > 0)
+ TYPE_LENGTH (result_type) = byte_stride * (high_bound - low_bound + 1);
else if (bit_stride > 0)
TYPE_LENGTH (result_type) =
(bit_stride * (high_bound - low_bound + 1) + 7) / 8;
@@ -1990,7 +2000,7 @@ resolve_dynamic_range (struct type *dyn_range_type,
CORE_ADDR value;
struct type *static_range_type, *static_target_type;
const struct dynamic_prop *prop;
- struct dynamic_prop low_bound, high_bound;
+ struct dynamic_prop low_bound, high_bound, stride;

gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE);

@@ -2022,12 +2032,19 @@ resolve_dynamic_range (struct type *dyn_range_type,
high_bound.data.const_val = 0;
}

+ prop = &TYPE_RANGE_DATA (dyn_range_type)->stride;
+ if (dwarf2_evaluate_property_signed (prop, NULL, addr_stack, &value, 1))
+ {
+ stride.kind = PROP_CONST;
+ stride.data.const_val = value;
+ }
+
static_target_type
= resolve_dynamic_type_internal (TYPE_TARGET_TYPE (dyn_range_type),
addr_stack, 0);
static_range_type = create_range_type (copy_type (dyn_range_type),
static_target_type,
- &low_bound, &high_bound);
+ &low_bound, &high_bound, &stride);
TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1;
return static_range_type;
}
diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
index a115857c0a..738b88d762 100644
--- a/gdb/gdbtypes.h
+++ b/gdb/gdbtypes.h
@@ -613,6 +613,10 @@ struct range_bounds

struct dynamic_prop high;

+ /* * Stride of range. */
+
+ struct dynamic_prop stride;
+
/* True if HIGH range bound contains the number of elements in the
subrange. This affects how the final hight bound is computed. */

@@ -1330,6 +1334,14 @@ extern bool set_type_align (struct type *, ULONGEST);
TYPE_RANGE_DATA(range_type)->high.kind
#define TYPE_LOW_BOUND_KIND(range_type) \
TYPE_RANGE_DATA(range_type)->low.kind
+#define TYPE_BYTE_STRIDE(range_type) \
+ TYPE_RANGE_DATA(range_type)->stride.data.const_val
+#define TYPE_BYTE_STRIDE_BLOCK(range_type) \
+ TYPE_RANGE_DATA(range_type)->stride.data.locexpr
+#define TYPE_BYTE_STRIDE_LOCLIST(range_type) \
+ TYPE_RANGE_DATA(range_type)->stride.data.loclist
+#define TYPE_BYTE_STRIDE_KIND(range_type) \
+ TYPE_RANGE_DATA(range_type)->stride.kind

/* Property accessors for the type data location. */
#define TYPE_DATA_LOCATION(thistype) \
@@ -1364,6 +1376,8 @@ extern bool set_type_align (struct type *, ULONGEST);
TYPE_HIGH_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))
#define TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED(arraytype) \
TYPE_LOW_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))
+#define TYPE_ARRAY_STRIDE_IS_UNDEFINED(arraytype) \
+ (TYPE_BYTE_STRIDE(TYPE_INDEX_TYPE(arraytype)) == 0)

#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \
(TYPE_HIGH_BOUND(TYPE_INDEX_TYPE((arraytype))))
@@ -1899,6 +1913,7 @@ extern struct type *create_array_type_with_stride
struct dynamic_prop *, unsigned int);

extern struct type *create_range_type (struct type *, struct type *,
+ const struct dynamic_prop *,
const struct dynamic_prop *,
const struct dynamic_prop *);

diff --git a/gdb/testsuite/gdb.fortran/vla-stride.exp b/gdb/testsuite/gdb.fortran/vla-stride.exp
new file mode 100644
index 0000000000..ed732da4ed
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-stride.exp
@@ -0,0 +1,44 @@
+# Copyright 2018 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+standard_testfile ".f90"
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+ {debug f90 quiet}] } {
+ return -1
+}
+
+if ![runto MAIN__] then {
+ perror "couldn't run to breakpoint MAIN__"
+ continue
+}
+
+gdb_breakpoint [gdb_get_line_number "re-reverse-elements"]
+gdb_continue_to_breakpoint "re-reverse-elements"
+gdb_test "print pvla" " = \\\(1, 2, 3, 4, 5, 6, 7, 8, 9, 10\\\)" \
+ "print re-reverse-elements"
+gdb_test "print pvla(1)" " = 1" "print first re-reverse-element"
+gdb_test "print pvla(10)" " = 10" "print last re-reverse-element"
+
+gdb_breakpoint [gdb_get_line_number "odd-elements"]
+gdb_continue_to_breakpoint "odd-elements"
+gdb_test "print pvla" " = \\\(1, 3, 5, 7, 9\\\)" "print odd-elements"
+gdb_test "print pvla(1)" " = 1" "print first odd-element"
+gdb_test "print pvla(5)" " = 9" "print last odd-element"
+
+gdb_breakpoint [gdb_get_line_number "single-element"]
+gdb_continue_to_breakpoint "single-element"
+gdb_test "print pvla" " = \\\(5\\\)" "print single-element"
+gdb_test "print pvla(1)" " = 5" "print one single-element"
diff --git a/gdb/testsuite/gdb.fortran/vla-stride.f90 b/gdb/testsuite/gdb.fortran/vla-stride.f90
new file mode 100644
index 0000000000..51d56e27cb
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-stride.f90
@@ -0,0 +1,29 @@
+! Copyright 2018 Free Software Foundation, Inc.
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 3 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+program vla_stride
+ integer, target, allocatable :: vla (:)
+ integer, pointer :: pvla (:)
+
+ allocate(vla(10))
+ vla = (/ (I, I = 1,10) /)
+
+ pvla => vla(10:1:-1)
+ pvla => pvla(10:1:-1)
+ pvla => vla(1:10:2) ! re-reverse-elements
+ pvla => vla(5:4:-2) ! odd-elements
+
+ pvla => null() ! single-element
+end program vla_stride
diff --git a/gdb/valarith.c b/gdb/valarith.c
index 807cdd5dbd..26cd17cc46 100644
--- a/gdb/valarith.c
+++ b/gdb/valarith.c
@@ -187,11 +187,17 @@ value_subscripted_rvalue (struct value *array, LONGEST index, int lowerbound)
struct type *array_type = check_typedef (value_type (array));
struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (array_type));
ULONGEST elt_size = type_length_units (elt_type);
- ULONGEST elt_offs = elt_size * (index - lowerbound);
+ LONGEST elt_offs = index - lowerbound;
+ LONGEST elt_stride = TYPE_BYTE_STRIDE (TYPE_INDEX_TYPE (array_type));
+
+ if (elt_stride != 0)
+ elt_offs *= elt_stride;
+ else
+ elt_offs *= elt_size;

if (index < lowerbound
|| (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)
- && elt_offs >= type_length_units (array_type))
+ && abs (elt_offs) >= type_length_units (array_type))
|| (VALUE_LVAL (array) != lval_memory
&& TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)))
{

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

2016-05-25 Bernhard Heckel <***@intel.com>

gdb/testsuite/Changelog:
* pointers.f90: Add cylic pointers.
* pointers.exp: Add print of cyclic pointers.
---
gdb/testsuite/gdb.fortran/pointers.exp | 20 ++++++++++++++++++++
gdb/testsuite/gdb.fortran/pointers.f90 | 12 ++++++++++++
2 files changed, 32 insertions(+)

diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp
index 0f6c9d3cdf..287803120a 100644
--- a/gdb/testsuite/gdb.fortran/pointers.exp
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -69,6 +69,24 @@ gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) 0x0" \
gdb_test "print *realp" "Cannot access memory at address 0x0" \
"print *realp, not associated"
gdb_test "print \$my_var = intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0"
+set test "print cyclicp1, not associated"
+gdb_test_multiple "print cyclicp1" $test {
+ -re "= \\( i = -?\\d+, p = 0x0 \\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "= \\( i = -?\\d+, p = <not associated> \\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+set test "print cyclicp1%p, not associated"
+gdb_test_multiple "print cyclicp1%p" $test {
+ -re "= \\(PTR TO -> \\( Type typewithpointer \\)\\) 0x0\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "= \\(PTR TO -> \\( Type typewithpointer \\)\\) <not associated>\r\n$gdb_prompt $" {
+ pass $test
+ }
+}


gdb_breakpoint [gdb_get_line_number "Before value assignment"]
@@ -131,6 +149,8 @@ gdb_test_multiple "print *(arrayOfPtr(3)%p)" $test_name {
pass $test_name
}
}
+gdb_test "print cyclicp1" "= \\( i = 1, p = $hex\( <.*>\)? \\)"
+gdb_test "print cyclicp1%p" "= \\(PTR TO -> \\( Type typewithpointer \\)\\) $hex\( <.*>\)?"
gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array"
gdb_test "print *((integer*) &intvla + 3)" "= 4" "print temporary pointer, allocated vla"
gdb_test "print \$pc" "= \\(PTR TO -> \\( void \\(\\)\\(\\)\\)\\) $hex <pointers\\+\\d+>" \
diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90
index c36398d76a..1ba5463745 100644
--- a/gdb/testsuite/gdb.fortran/pointers.f90
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -20,6 +20,11 @@ program pointers
integer, allocatable :: ivla2 (:, :)
end type two

+ type :: typeWithPointer
+ integer i
+ type(typeWithPointer), pointer:: p
+ end type typeWithPointer
+
type :: twoPtr
type (two), pointer :: p
end type twoPtr
@@ -34,6 +39,7 @@ program pointers
real, target :: realv
type(two), target :: twov
type(twoPtr) :: arrayOfPtr (3)
+ type(typeWithPointer), target:: cyclicp1,cyclicp2

logical, pointer :: logp
complex, pointer :: comp
@@ -57,6 +63,8 @@ program pointers
nullify (arrayOfPtr(1)%p)
nullify (arrayOfPtr(2)%p)
nullify (arrayOfPtr(3)%p)
+ nullify (cyclicp1%p)
+ nullify (cyclicp2%p)

logp => logv ! Before pointer assignment
comp => comv
@@ -68,6 +76,10 @@ program pointers
realp => realv
twop => twov
arrayOfPtr(2)%p => twov
+ cyclicp1%i = 1
+ cyclicp1%p => cyclicp2
+ cyclicp2%i = 2
+ cyclicp2%p => cyclicp1

logv = associated(logp) ! Before value assignment
comv = cmplx(1,2)

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

When dereferencing pointers to dynamic target types,
resolve the target type.

2016-06-30 Bernhard Heckel <***@intel.com>

gdb/Changelog:
* NEWS: Added entry.
* c-valprint.c (c_print_val): Resolve dynamic target types.
* valops.c (value_ind): Resolve dynamic target types.
* valprint.c (check_printable): Don't shortcut not associated
pointers.

gdb/Testsuite/Changelog:
* pointers.f90: Added pointer to dynamic types.
* gdb.fortran/pointers.exp: New.
---
gdb/NEWS | 2 +
gdb/c-valprint.c | 22 ++++
gdb/testsuite/gdb.cp/vla-cxx.exp | 6 ++
gdb/testsuite/gdb.fortran/pointers.exp | 137 +++++++++++++++++++++++++
gdb/testsuite/gdb.fortran/pointers.f90 | 17 +++
gdb/valops.c | 16 ++-
gdb/valprint.c | 6 --
7 files changed, 198 insertions(+), 8 deletions(-)
create mode 100644 gdb/testsuite/gdb.fortran/pointers.exp

diff --git a/gdb/NEWS b/gdb/NEWS
index ff9b192a38..8fe8faecb6 100644
--- a/gdb/NEWS
+++ b/gdb/NEWS
@@ -650,6 +650,8 @@ show disassembler-options
* GDBserver now supports recording btrace without maintaining an active
GDB connection.

+* Fortran: Support pointers to dynamic types.
+
* GDB now supports a negative repeat count in the 'x' command to examine
memory backward from the given address. For example:

diff --git a/gdb/c-valprint.c b/gdb/c-valprint.c
index c4c0918e26..254ebd1ee6 100644
--- a/gdb/c-valprint.c
+++ b/gdb/c-valprint.c
@@ -653,6 +653,28 @@ c_value_print (struct value *val, struct ui_file *stream,
else
{
/* normal case */
+ if (TYPE_CODE (type) == TYPE_CODE_PTR
+ && is_dynamic_type (type))
+ {
+ CORE_ADDR addr;
+ if (NULL != TYPE_DATA_LOCATION (TYPE_TARGET_TYPE (type)))
+ addr = value_address (val);
+ else
+ addr = value_as_address (val);
+
+ /* We resolve the target-type only when the
+ pointer is associated. */
+ if ((addr != 0)
+ && !type_not_associated (type))
+ TYPE_TARGET_TYPE (type) =
+ resolve_dynamic_type (TYPE_TARGET_TYPE (type),
+ NULL, addr);
+ }
+ else
+ {
+ /* Do nothing. References are already resolved from the beginning,
+ only pointers are resolved when we actual need the target. */
+ }
fprintf_filtered (stream, "(");
type_print (value_type (val), "", stream, -1);
fprintf_filtered (stream, ") ");
diff --git a/gdb/testsuite/gdb.cp/vla-cxx.exp b/gdb/testsuite/gdb.cp/vla-cxx.exp
index 2cf2d9868f..32e4329f93 100644
--- a/gdb/testsuite/gdb.cp/vla-cxx.exp
+++ b/gdb/testsuite/gdb.cp/vla-cxx.exp
@@ -26,6 +26,10 @@ if ![runto_main] {
gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
gdb_continue_to_breakpoint "Before pointer assignment"
gdb_test "ptype ptr" "int \\(\\*\\)\\\[variable length\\\]" "ptype ptr, Before pointer assignment"
+gdb_test "print ptr" "\\(int \\(\\*\\)\\\[variable length\\\]\\) 0x0" \
+ "print ptr, Before pointer assignment"
+gdb_test "print *ptr" "Cannot access memory at address 0x0" \
+ "print *ptr, Before pointer assignment"

gdb_breakpoint [gdb_get_line_number "vlas_filled"]
gdb_continue_to_breakpoint "vlas_filled"
@@ -38,3 +42,5 @@ gdb_test "print vlaref" " = \\(int \\(&\\)\\\[3\\\]\\) @$hex: \\{5, 7, 9\\}"
gdb_test "print vlaref2" " = \\(.*\\) @$hex: \\{5, 7, 9\\}"
gdb_test "print c" " = \\{e = \\{c = @$hex\\}\\}"
gdb_test "ptype ptr" "int \\(\\*\\)\\\[3\\\]"
+gdb_test "print ptr" "\\(int \\(\\*\\)\\\[3\\\]\\) $hex"
+gdb_test "print *ptr" " = \\{5, 7, 9\\}"
diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp
new file mode 100644
index 0000000000..0f6c9d3cdf
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -0,0 +1,137 @@
+# Copyright 2018 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+standard_testfile "pointers.f90"
+load_lib fortran.exp
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+ {debug f90 quiet}] } {
+ return -1
+}
+
+if ![runto_main] {
+ untested "could not run to main"
+ return -1
+}
+
+# Depending on the compiler being used, the type names can be printed differently.
+set logical [fortran_logical4]
+set real [fortran_real4]
+set int [fortran_int4]
+set complex [fortran_complex4]
+
+
+gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
+gdb_continue_to_breakpoint "Before pointer assignment"
+gdb_test "print logp" "= \\(PTR TO -> \\( $logical \\)\\) 0x0" \
+ "print logp, not associated"
+gdb_test "print *logp" "Cannot access memory at address 0x0" \
+ "print *logp, not associated"
+gdb_test "print comp" "= \\(PTR TO -> \\( $complex \\)\\) 0x0" \
+ "print comp, not associated"
+gdb_test "print *comp" "Cannot access memory at address 0x0" \
+ "print *comp, not associated"
+gdb_test "print charp" "= \\(PTR TO -> \\( character\\*1 \\)\\) 0x0" \
+ "print charp, not associated"
+gdb_test "print *charp" "Cannot access memory at address 0x0" \
+ "print *charp, not associated"
+gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3 \\)\\) 0x0" \
+ "print charap, not associated"
+gdb_test "print *charap" "Cannot access memory at address 0x0" \
+ "print *charap, not associated"
+gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0" \
+ "print intp, not associated"
+gdb_test "print *intp" "Cannot access memory at address 0x0" \
+ "print *intp, not associated"
+set test "print intap, not associated"
+gdb_test_multiple "print intap" $test {
+ -re " = \\(PTR TO -> \\( $int \\(:,:\\)\\)\\) <not associated>\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re " = <not associated>\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) 0x0" \
+ "print realp, not associated"
+gdb_test "print *realp" "Cannot access memory at address 0x0" \
+ "print *realp, not associated"
+gdb_test "print \$my_var = intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0"
+
+
+gdb_breakpoint [gdb_get_line_number "Before value assignment"]
+gdb_continue_to_breakpoint "Before value assignment"
+gdb_test "print *(twop)%ivla2" "= <not allocated>"
+
+
+gdb_breakpoint [gdb_get_line_number "After value assignment"]
+gdb_continue_to_breakpoint "After value assignment"
+gdb_test "print logp" "= \\(PTR TO -> \\( $logical \\)\\) $hex\( <.*>\)?"
+gdb_test "print *logp" "= \\.TRUE\\."
+gdb_test "print comp" "= \\(PTR TO -> \\( $complex \\)\\) $hex\( <.*>\)?"
+gdb_test "print *comp" "= \\(1,2\\)"
+gdb_test "print charp" "= \\(PTR TO -> \\( character\\*1 \\)\\) $hex\( <.*>\)?"
+gdb_test "print *charp" "= 'a'"
+gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\( <.*>\)?"
+gdb_test "print *charap" "= 'abc'"
+gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) $hex\( <.*>\)?"
+gdb_test "print *intp" "= 10"
+set test_name "print intap, associated"
+gdb_test_multiple "print intap" $test_name {
+ -re "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+ -re "= \\(PTR TO -> \\( $int \\(10,2\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
+ gdb_test "print *intap" "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)"
+ pass $test_name
+ }
+}
+set test_name "print intvlap, associated"
+gdb_test_multiple "print intvlap" $test_name {
+ -re "= \\(2, 2, 2, 4(, 2){6}\\)\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+ -re "= \\(PTR TO -> \\( $int \\(10\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
+ gdb_test "print *intvlap" "= \\(2, 2, 2, 4(, 2){6}\\)"
+ pass $test_name
+ }
+}
+gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) $hex\( <.*>\)?"
+gdb_test "print *realp" "= 3\\.14000\\d+"
+gdb_test "print arrayOfPtr(2)%p" "= \\(PTR TO -> \\( Type two \\)\\) $hex\( <.*>\)?"
+gdb_test "print *(arrayOfPtr(2)%p)" \
+ "= \\( ivla1 = \\(11, 12, 13\\), ivla2 = \\(\\( 211, 221\\) \\( 212, 222\\) \\) \\)"
+set test_name "print arrayOfPtr(3)%p"
+gdb_test_multiple $test_name $test_name {
+ -re "= \\(PTR TO -> \\( Type two \\)\\) <not associated>\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+ -re "= \\(PTR TO -> \\( Type two \\)\\) 0x0\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+}
+set test_name "print *(arrayOfPtr(3)%p), associated"
+gdb_test_multiple "print *(arrayOfPtr(3)%p)" $test_name {
+ -re "Cannot access memory at address 0x0\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+ -re "Attempt to take contents of a not associated pointer.\r\n$gdb_prompt $" {
+ pass $test_name
+ }
+}
+gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array"
+gdb_test "print *((integer*) &intvla + 3)" "= 4" "print temporary pointer, allocated vla"
+gdb_test "print \$pc" "= \\(PTR TO -> \\( void \\(\\)\\(\\)\\)\\) $hex <pointers\\+\\d+>" \
+ "Print program counter"
diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90
index dd4fe811be..c36398d76a 100644
--- a/gdb/testsuite/gdb.fortran/pointers.f90
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -20,14 +20,20 @@ program pointers
integer, allocatable :: ivla2 (:, :)
end type two

+ type :: twoPtr
+ type (two), pointer :: p
+ end type twoPtr
+
logical, target :: logv
complex, target :: comv
character, target :: charv
character (len=3), target :: chara
integer, target :: intv
integer, target, dimension (10,2) :: inta
+ integer, target, allocatable, dimension (:) :: intvla
real, target :: realv
type(two), target :: twov
+ type(twoPtr) :: arrayOfPtr (3)

logical, pointer :: logp
complex, pointer :: comp
@@ -35,6 +41,7 @@ program pointers
character (len=3), pointer:: charap
integer, pointer :: intp
integer, pointer, dimension (:,:) :: intap
+ integer, pointer, dimension (:) :: intvlap
real, pointer :: realp
type(two), pointer :: twop

@@ -44,8 +51,12 @@ program pointers
nullify (charap)
nullify (intp)
nullify (intap)
+ nullify (intvlap)
nullify (realp)
nullify (twop)
+ nullify (arrayOfPtr(1)%p)
+ nullify (arrayOfPtr(2)%p)
+ nullify (arrayOfPtr(3)%p)

logp => logv ! Before pointer assignment
comp => comv
@@ -53,8 +64,10 @@ program pointers
charap => chara
intp => intv
intap => inta
+ intvlap => intvla
realp => realv
twop => twov
+ arrayOfPtr(2)%p => twov

logv = associated(logp) ! Before value assignment
comv = cmplx(1,2)
@@ -63,6 +76,10 @@ program pointers
intv = 10
inta(:,:) = 1
inta(3,1) = 3
+ allocate (intvla(10))
+ intvla(:) = 2
+ intvla(4) = 4
+ intvlap => intvla
realv = 3.14

allocate (twov%ivla1(3))
diff --git a/gdb/valops.c b/gdb/valops.c
index a34e74b2be..90dc2fec0c 100644
--- a/gdb/valops.c
+++ b/gdb/valops.c
@@ -1558,6 +1558,19 @@ value_ind (struct value *arg1)
if (TYPE_CODE (base_type) == TYPE_CODE_PTR)
{
struct type *enc_type;
+ CORE_ADDR addr;
+
+ if (type_not_associated (base_type))
+ error (_("Attempt to take contents of a not associated pointer."));
+
+ if (NULL != TYPE_DATA_LOCATION (TYPE_TARGET_TYPE (base_type)))
+ addr = value_address (arg1);
+ else
+ addr = value_as_address (arg1);
+
+ if (addr != 0)
+ TYPE_TARGET_TYPE (base_type) =
+ resolve_dynamic_type (TYPE_TARGET_TYPE (base_type), NULL, addr);

/* We may be pointing to something embedded in a larger object.
Get the real type of the enclosing object. */
@@ -1573,8 +1586,7 @@ value_ind (struct value *arg1)
else
/* Retrieve the enclosing object pointed to. */
arg2 = value_at_lazy (enc_type,
- (value_as_address (arg1)
- - value_pointed_to_offset (arg1)));
+ (addr - value_pointed_to_offset (arg1)));

enc_type = value_type (arg2);
return readjust_indirect_value_type (arg2, enc_type, base_type, arg1);
diff --git a/gdb/valprint.c b/gdb/valprint.c
index b2236f8931..35f22b6d43 100644
--- a/gdb/valprint.c
+++ b/gdb/valprint.c
@@ -1108,12 +1108,6 @@ value_check_printable (struct value *val, struct ui_file *stream,
return 0;
}

- if (type_not_associated (value_type (val)))
- {
- val_print_not_associated (stream);
- return 0;
- }
-
if (type_not_allocated (value_type (val)))
{
val_print_not_allocated (stream);

[Eli Zaretskii]

Date: Tue, 27 Nov 2018 19:31:35 +0100
When dereferencing pointers to dynamic target types,
resolve the target type.
* NEWS: Added entry.
* c-valprint.c (c_print_val): Resolve dynamic target types.
* valops.c (value_ind): Resolve dynamic target types.
* valprint.c (check_printable): Don't shortcut not associated
pointers.
* pointers.f90: Added pointer to dynamic types.
* gdb.fortran/pointers.exp: New.

OK for the NEWS part.

Thanks.

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

Show the type of not-allocated and/or not-associated types
as this is known. For array types and pointer to array types
we are going to print the number of ranks.

2016-06-30 Bernhard Heckel <***@intel.com>

gdb/ChangeLog:
* f-typeprint.c (f_print_type): Don't bypass dangling types.
(f_type_print_varspec_suffix): Add print_rank parameter.
(f_type_print_varspec_suffix): Print ranks of array types
in case they dangling.
(f_type_print_base): Add print_rank parameter.

gdb/Testsuite/ChangeLog:
* gdb.fortran/pointers.f90: New.
* gdb.fortran/print_type.exp: New.
* gdb.fortran/vla-ptype.exp: Adapt expected results.
* gdb.fortran/vla-type.exp: Likewise.
* gdb.fortran/vla-value.exp: Likewise.
* gdb.fortran/oop-extend-type.exp: Likewise.
* gdb.mi/mi-vla-fortran.exp: Likewise.
---
gdb/f-typeprint.c | 93 ++++++++--------
gdb/testsuite/gdb.fortran/oop-extend-type.exp | 2 +-
gdb/testsuite/gdb.fortran/pointers.f90 | 80 ++++++++++++++
gdb/testsuite/gdb.fortran/print_type.exp | 100 ++++++++++++++++++
gdb/testsuite/gdb.fortran/vla-ptype.exp | 12 +--
gdb/testsuite/gdb.fortran/vla-type.exp | 7 +-
gdb/testsuite/gdb.fortran/vla-value.exp | 4 +-
gdb/testsuite/gdb.mi/mi-vla-fortran.exp | 8 +-
8 files changed, 247 insertions(+), 59 deletions(-)
create mode 100644 gdb/testsuite/gdb.fortran/pointers.f90
create mode 100755 gdb/testsuite/gdb.fortran/print_type.exp

diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c
index 133eaf9b98..f8ade5b835 100644
--- a/gdb/f-typeprint.c
+++ b/gdb/f-typeprint.c
@@ -37,7 +37,7 @@ static void f_type_print_args (struct type *, struct ui_file *);
#endif

static void f_type_print_varspec_suffix (struct type *, struct ui_file *, int,
- int, int, int);
+ int, int, int, int);

void f_type_print_varspec_prefix (struct type *, struct ui_file *,
int, int);
@@ -53,18 +53,6 @@ f_print_type (struct type *type, const char *varstring, struct ui_file *stream,
{
enum type_code code;

- if (type_not_associated (type))
- {
- val_print_not_associated (stream);
- return;
- }
-
- if (type_not_allocated (type))
- {
- val_print_not_allocated (stream);
- return;
- }
-
f_type_print_base (type, stream, show, level);
code = TYPE_CODE (type);
if ((varstring != NULL && *varstring != '\0')
@@ -89,7 +77,7 @@ f_print_type (struct type *type, const char *varstring, struct ui_file *stream,

demangled_args = (*varstring != '\0'
&& varstring[strlen (varstring) - 1] == ')');
- f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0);
+ f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0, 0);
}
}

@@ -159,7 +147,7 @@ f_type_print_varspec_prefix (struct type *type, struct ui_file *stream,
static void
f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
int show, int passed_a_ptr, int demangled_args,
- int arrayprint_recurse_level)
+ int arrayprint_recurse_level, int print_rank_only)
{
int upper_bound, lower_bound;

@@ -183,34 +171,50 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
fprintf_filtered (stream, "(");

if (type_not_associated (type))
- val_print_not_associated (stream);
+ print_rank_only = 1;
else if (type_not_allocated (type))
- val_print_not_allocated (stream);
+ print_rank_only = 1;
+ else if ((TYPE_ASSOCIATED_PROP (type)
+ && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ASSOCIATED_PROP (type)))
+ || (TYPE_ALLOCATED_PROP (type)
+ && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ALLOCATED_PROP (type)))
+ || (TYPE_DATA_LOCATION (type)
+ && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_DATA_LOCATION (type))))
+ /* This case exist when we ptype a typename which has the
+ dynamic properties but cannot be resolved as there is
+ no object. */
+ print_rank_only = 1;
+
+ if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
+ f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
+ 0, 0, arrayprint_recurse_level,
+ print_rank_only);
+
+ if (print_rank_only == 1)
+ fprintf_filtered (stream, ":");
else
- {
- if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
- 0, 0, arrayprint_recurse_level);
-
- lower_bound = f77_get_lowerbound (type);
- if (lower_bound != 1) /* Not the default. */
- fprintf_filtered (stream, "%d:", lower_bound);
-
- /* Make sure that, if we have an assumed size array, we
- print out a warning and print the upperbound as '*'. */
-
- if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
- fprintf_filtered (stream, "*");
- else
- {
- upper_bound = f77_get_upperbound (type);
- fprintf_filtered (stream, "%d", upper_bound);
- }
-
- if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
- f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
- 0, 0, arrayprint_recurse_level);
- }
+ {
+ lower_bound = f77_get_lowerbound (type);
+ if (lower_bound != 1) /* Not the default. */
+ fprintf_filtered (stream, "%d:", lower_bound);
+
+ /* Make sure that, if we have an assumed size array, we
+ print out a warning and print the upperbound as '*'. */
+
+ if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
+ fprintf_filtered (stream, "*");
+ else
+ {
+ upper_bound = f77_get_upperbound (type);
+ fprintf_filtered (stream, "%d", upper_bound);
+ }
+ }
+
+ if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
+ f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
+ 0, 0, arrayprint_recurse_level,
+ print_rank_only);
+
if (arrayprint_recurse_level == 1)
fprintf_filtered (stream, ")");
else
@@ -221,13 +225,14 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
case TYPE_CODE_PTR:
case TYPE_CODE_REF:
f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0,
- arrayprint_recurse_level);
+ arrayprint_recurse_level, 0);
fprintf_filtered (stream, ")");
break;

case TYPE_CODE_FUNC:
f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
- passed_a_ptr, 0, arrayprint_recurse_level);
+ passed_a_ptr, 0, arrayprint_recurse_level,
+ 0);
if (passed_a_ptr)
fprintf_filtered (stream, ")");

@@ -412,7 +417,7 @@ f_type_print_base (struct type *type, struct ui_file *stream, int show,
fputs_filtered (" :: ", stream);
fputs_filtered (TYPE_FIELD_NAME (type, index), stream);
f_type_print_varspec_suffix (TYPE_FIELD_TYPE (type, index),
- stream, show - 1, 0, 0, 0);
+ stream, show - 1, 0, 0, 0, 0);
fputs_filtered ("\n", stream);
}
fprintfi_filtered (level, stream, "End Type ");
diff --git a/gdb/testsuite/gdb.fortran/oop-extend-type.exp b/gdb/testsuite/gdb.fortran/oop-extend-type.exp
index 8c3bb50a3a..85eef493be 100644
--- a/gdb/testsuite/gdb.fortran/oop-extend-type.exp
+++ b/gdb/testsuite/gdb.fortran/oop-extend-type.exp
@@ -31,7 +31,7 @@ set real [fortran_real4]

gdb_breakpoint [gdb_get_line_number "! Before vla allocation"]
gdb_continue_to_breakpoint "! Before vla allocation" ".*! Before vla allocation"
-gdb_test "whatis wp_vla" "type = <not allocated>"
+gdb_test "whatis wp_vla" "type = Type waypoint \\(:\\)"

gdb_breakpoint [gdb_get_line_number "! After value assignment"]
gdb_continue_to_breakpoint "! After value assignment" ".*! After value assignment"
diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90
new file mode 100644
index 0000000000..dd4fe811be
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/pointers.f90
@@ -0,0 +1,80 @@
+! Copyright 2018 Free Software Foundation, Inc.
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 3 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+program pointers
+
+ type :: two
+ integer, allocatable :: ivla1 (:)
+ integer, allocatable :: ivla2 (:, :)
+ end type two
+
+ logical, target :: logv
+ complex, target :: comv
+ character, target :: charv
+ character (len=3), target :: chara
+ integer, target :: intv
+ integer, target, dimension (10,2) :: inta
+ real, target :: realv
+ type(two), target :: twov
+
+ logical, pointer :: logp
+ complex, pointer :: comp
+ character, pointer:: charp
+ character (len=3), pointer:: charap
+ integer, pointer :: intp
+ integer, pointer, dimension (:,:) :: intap
+ real, pointer :: realp
+ type(two), pointer :: twop
+
+ nullify (logp)
+ nullify (comp)
+ nullify (charp)
+ nullify (charap)
+ nullify (intp)
+ nullify (intap)
+ nullify (realp)
+ nullify (twop)
+
+ logp => logv ! Before pointer assignment
+ comp => comv
+ charp => charv
+ charap => chara
+ intp => intv
+ intap => inta
+ realp => realv
+ twop => twov
+
+ logv = associated(logp) ! Before value assignment
+ comv = cmplx(1,2)
+ charv = "a"
+ chara = "abc"
+ intv = 10
+ inta(:,:) = 1
+ inta(3,1) = 3
+ realv = 3.14
+
+ allocate (twov%ivla1(3))
+ allocate (twov%ivla2(2,2))
+ twov%ivla1(1) = 11
+ twov%ivla1(2) = 12
+ twov%ivla1(3) = 13
+ twov%ivla2(1,1) = 211
+ twov%ivla2(2,1) = 221
+ twov%ivla2(1,2) = 212
+ twov%ivla2(2,2) = 222
+
+ intv = intv + 1 ! After value assignment
+
+end program pointers
diff --git a/gdb/testsuite/gdb.fortran/print_type.exp b/gdb/testsuite/gdb.fortran/print_type.exp
new file mode 100755
index 0000000000..538f28c5d2
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/print_type.exp
@@ -0,0 +1,100 @@
+# Copyright 2018 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+standard_testfile "pointers.f90"
+load_lib fortran.exp
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+ {debug f90 quiet}] } {
+ return -1
+}
+
+
+if ![runto_main] {
+ untested "could not run to main"
+ return -1
+}
+
+# Depending on the compiler being used, the type names can be printed differently.
+set logical [fortran_logical4]
+set real [fortran_real4]
+set int [fortran_int4]
+set complex [fortran_complex4]
+
+gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
+gdb_continue_to_breakpoint "Before pointer assignment"
+gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)" "ptype logp, not associated"
+gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)" "ptype comp, not associated"
+gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)" "ptype charp, not associated"
+gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)" "ptype charap, not associated"
+gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)" "ptype intp, not associated"
+set test "ptype intap, not associated"
+gdb_test_multiple "ptype intap" $test {
+ -re "type = PTR TO -> \\( $int \\(:,:\\)\\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "type = $int \\(:,:\\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)" "ptype realp, not associated"
+gdb_test "ptype twop" \
+ [multi_line "type = PTR TO -> \\( Type two" \
+ " $int :: ivla1\\(:\\)" \
+ " $int :: ivla2\\(:,:\\)" \
+ "End Type two \\)"] \
+ "ptype twop, not associated"
+gdb_test "ptype two" \
+ [multi_line "type = Type two" \
+ " $int :: ivla1\\(:\\)" \
+ " $int :: ivla2\\(:,:\\)" \
+ "End Type two"]
+
+
+gdb_breakpoint [gdb_get_line_number "Before value assignment"]
+gdb_continue_to_breakpoint "Before value assignment"
+gdb_test "ptype twop" \
+ [multi_line "type = PTR TO -> \\( Type two" \
+ " $int :: ivla1\\(:\\)" \
+ " $int :: ivla2\\(:,:\\)" \
+ "End Type two \\)"]
+
+
+gdb_breakpoint [gdb_get_line_number "After value assignment"]
+gdb_continue_to_breakpoint "After value assignment"
+gdb_test "ptype logv" "type = $logical"
+gdb_test "ptype comv" "type = $complex"
+gdb_test "ptype charv" "type = character\\*1"
+gdb_test "ptype chara" "type = character\\*3"
+gdb_test "ptype intv" "type = $int"
+gdb_test "ptype inta" "type = $int \\(10,2\\)"
+gdb_test "ptype realv" "type = $real"
+
+
+gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)"
+gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)"
+gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)"
+gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)"
+gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)"
+set test "ptype intap"
+gdb_test_multiple $test $test {
+ -re "type = $int \\(10,2\\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "type = PTR TO -> \\( $int \\(10,2\\)\\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)"
diff --git a/gdb/testsuite/gdb.fortran/vla-ptype.exp b/gdb/testsuite/gdb.fortran/vla-ptype.exp
index 5351a0aa2e..fa248c5a0c 100644
--- a/gdb/testsuite/gdb.fortran/vla-ptype.exp
+++ b/gdb/testsuite/gdb.fortran/vla-ptype.exp
@@ -32,9 +32,9 @@ set real [fortran_real4]
# Check the ptype of various VLA states and pointer to VLA's.
gdb_breakpoint [gdb_get_line_number "vla1-init"]
gdb_continue_to_breakpoint "vla1-init"
-gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not initialized"
-gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not initialized"
-gdb_test "ptype pvla" "type = <not associated>" "ptype pvla not initialized"
+gdb_test "ptype vla1" "type = $real \\(:,:,:\\)" "ptype vla1 not initialized"
+gdb_test "ptype vla2" "type = $real \\(:,:,:\\)" "ptype vla2 not initialized"
+gdb_test "ptype pvla" "type = $real \\(:,:,:\\)" "ptype pvla not initialized"
gdb_test "ptype vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \
"ptype vla1(3, 6, 9) not initialized"
gdb_test "ptype vla2(5, 45, 20)" \
@@ -81,20 +81,20 @@ gdb_test "ptype vla2(5, 45, 20)" "type = $real" \

gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
gdb_continue_to_breakpoint "pvla-deassociated"
-gdb_test "ptype pvla" "type = <not associated>" "ptype pvla deassociated"
+gdb_test "ptype pvla" "type = $real \\(:,:,:\\)" "ptype pvla deassociated"
gdb_test "ptype pvla(5, 45, 20)" \
"no such vector element \\\(vector not associated\\\)" \
"ptype pvla(5, 45, 20) not associated"

gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
gdb_continue_to_breakpoint "vla1-deallocated"
-gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not allocated"
+gdb_test "ptype vla1" "type = $real \\(:,:,:\\)" "ptype vla1 not allocated"
gdb_test "ptype vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \
"ptype vla1(3, 6, 9) not allocated"

gdb_breakpoint [gdb_get_line_number "vla2-deallocated"]
gdb_continue_to_breakpoint "vla2-deallocated"
-gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not allocated"
+gdb_test "ptype vla2" "type = $real \\(:,:,:\\)" "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"
diff --git a/gdb/testsuite/gdb.fortran/vla-type.exp b/gdb/testsuite/gdb.fortran/vla-type.exp
index aff0d5a258..6f2d6a4009 100755
--- a/gdb/testsuite/gdb.fortran/vla-type.exp
+++ b/gdb/testsuite/gdb.fortran/vla-type.exp
@@ -132,7 +132,10 @@ gdb_test "ptype fivearr(2)%tone" \
"End Type one" ]

# Check allocation status of dynamic array and it's dynamic members
-gdb_test "ptype fivedynarr" "type = <not allocated>"
+gdb_test "ptype fivedynarr" \
+ [multi_line "type = Type five" \
+ " Type one :: tone" \
+ "End Type five \\(:\\)" ]
gdb_test "next" ""
gdb_test "ptype fivedynarr(2)" \
[multi_line "type = Type five" \
@@ -141,7 +144,7 @@ gdb_test "ptype fivedynarr(2)" \
"ptype fivedynarr(2), tone is not allocated"
gdb_test "ptype fivedynarr(2)%tone" \
[multi_line "type = Type one" \
- " $int :: ivla\\(<not allocated>\\)" \
+ " $int :: ivla\\(:,:,:\\)" \
"End Type one" ] \
"ptype fivedynarr(2)%tone, not allocated"

diff --git a/gdb/testsuite/gdb.fortran/vla-value.exp b/gdb/testsuite/gdb.fortran/vla-value.exp
index 4b1842e38c..5a831a3964 100644
--- a/gdb/testsuite/gdb.fortran/vla-value.exp
+++ b/gdb/testsuite/gdb.fortran/vla-value.exp
@@ -35,7 +35,7 @@ gdb_breakpoint [gdb_get_line_number "vla1-init"]
gdb_continue_to_breakpoint "vla1-init"
gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1"
gdb_test "print &vla1" \
- " = \\\(PTR TO -> \\\( $real \\\(<not allocated>\\\)\\\)\\\) $hex" \
+ " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\)\\\)\\\) $hex" \
"print non-allocated &vla1"
gdb_test "print vla1(1,1,1)" "no such vector element \\\(vector not allocated\\\)" \
"print member in non-allocated vla1 (1)"
@@ -76,7 +76,7 @@ gdb_test "print vla1(9, 9, 9)" " = 999" \
# Try to access values in undefined pointer to VLA (dangling)
gdb_test "print pvla" " = <not associated>" "print undefined pvla"
gdb_test "print &pvla" \
- " = \\\(PTR TO -> \\\( $real \\\(<not associated>\\\)\\\)\\\) $hex" \
+ " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\)\\\)\\\) $hex" \
"print non-associated &pvla"
gdb_test "print pvla(1, 3, 8)" "no such vector element \\\(vector not associated\\\)" \
"print undefined pvla(1,3,8)"
diff --git a/gdb/testsuite/gdb.mi/mi-vla-fortran.exp b/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
index b6e777235c..14b611f7b5 100644
--- a/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
+++ b/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
@@ -51,10 +51,10 @@ mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
mi_gdb_test "500-data-evaluate-expression vla1" \
"500\\^done,value=\"<not allocated>\"" "evaluate not allocated vla, before allocation"

-mi_create_varobj_checked vla1_not_allocated vla1 "<not allocated>" \
+mi_create_varobj_checked vla1_not_allocated vla1 "$real \\(:\\)" \
"create local variable vla1_not_allocated"
mi_gdb_test "501-var-info-type vla1_not_allocated" \
- "501\\^done,type=\"<not allocated>\"" \
+ "501\\^done,type=\"$real \\(:\\)\"" \
"info type variable vla1_not_allocated"
mi_gdb_test "502-var-show-format vla1_not_allocated" \
"502\\^done,format=\"natural\"" \
@@ -146,10 +146,10 @@ gdb_expect {
-re "580\\^done,value=\"<not associated>\".*${mi_gdb_prompt}$" {
pass $test

- mi_create_varobj_checked pvla2_not_associated pvla2 "<not associated>" \
+ mi_create_varobj_checked pvla2_not_associated pvla2 "$real \\(:,:\\)" \
"create local variable pvla2_not_associated"
mi_gdb_test "581-var-info-type pvla2_not_associated" \
- "581\\^done,type=\"<not associated>\"" \
+ "581\\^done,type=\"$real \\(:,:\\)\"" \
"info type variable pvla2_not_associated"
mi_gdb_test "582-var-show-format pvla2_not_associated" \
"582\\^done,format=\"natural\"" \

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

2016-03-04 Bernhard Heckel <***@intel.com>

gdb/Changelog:

* eval.c (evaluate_subexp_for_sizeof): Dereference pointer when
associated and allocated.

gdb/testsuite/Changelog:

* gdb fortran/vla-sizeof.exp: Adapt expected output.
* gdb.fortran/pointers.exp: Likewise.
---
gdb/eval.c | 9 +++++++++
gdb/testsuite/gdb.fortran/pointers.exp | 8 ++++++++
2 files changed, 17 insertions(+)

diff --git a/gdb/eval.c b/gdb/eval.c
index 047aba59ae..3413e208e5 100644
--- a/gdb/eval.c
+++ b/gdb/eval.c
@@ -3248,6 +3248,15 @@ evaluate_subexp_for_sizeof (struct expression *exp, int *pos,
if (exp->language_defn->la_language == language_cplus
&& (TYPE_IS_REFERENCE (type)))
type = check_typedef (TYPE_TARGET_TYPE (type));
+ else if (exp->language_defn->la_language == language_fortran)
+ {
+ if (type_not_associated (type) || type_not_allocated (type))
+ return value_from_longest (size_type, 0);
+
+ if (TYPE_CODE (type) == TYPE_CODE_PTR)
+ type = check_typedef (TYPE_TARGET_TYPE (type));
+ }
+
return value_from_longest (size_type, (LONGEST) TYPE_LENGTH (type));
}

diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp
index 287803120a..4dcc5c61e3 100644
--- a/gdb/testsuite/gdb.fortran/pointers.exp
+++ b/gdb/testsuite/gdb.fortran/pointers.exp
@@ -94,6 +94,10 @@ gdb_continue_to_breakpoint "Before value assignment"
gdb_test "print *(twop)%ivla2" "= <not allocated>"


+gdb_test "print sizeof(intp)" "= 4"
+gdb_test "print sizeof(realp)" "= 4"
+gdb_test "print sizeof(charap)" "= 3"
+
gdb_breakpoint [gdb_get_line_number "After value assignment"]
gdb_continue_to_breakpoint "After value assignment"
gdb_test "print logp" "= \\(PTR TO -> \\( $logical \\)\\) $hex\( <.*>\)?"
@@ -155,3 +159,7 @@ gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array"
gdb_test "print *((integer*) &intvla + 3)" "= 4" "print temporary pointer, allocated vla"
gdb_test "print \$pc" "= \\(PTR TO -> \\( void \\(\\)\\(\\)\\)\\) $hex <pointers\\+\\d+>" \
"Print program counter"
+
+gdb_test "print sizeof(intp)" "= 4"
+gdb_test "print sizeof(realp)" "= 4"
+gdb_test "print sizeof(charap)" "= 3"

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

gdb/testsuite/Changelog:

* gdb fortran/vla-sizeof.exp: Add tests of sizeof applied
to indexed and sliced arrays.
---
gdb/testsuite/gdb.fortran/vla-sizeof.exp | 12 ++++++++++++
1 file changed, 12 insertions(+)

diff --git a/gdb/testsuite/gdb.fortran/vla-sizeof.exp b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
index 83bc849619..fca355f939 100644
--- a/gdb/testsuite/gdb.fortran/vla-sizeof.exp
+++ b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
@@ -29,21 +29,33 @@ if ![runto_main] {
gdb_breakpoint [gdb_get_line_number "vla1-init"]
gdb_continue_to_breakpoint "vla1-init"
gdb_test "print sizeof(vla1)" " = 0" "print sizeof non-allocated vla1"
+gdb_test "print sizeof(vla1(3,2,1))" "no such vector element \\(vector not allocated\\)" \
+ "print sizeof non-allocated indexed vla1"
+gdb_test "print sizeof(vla1(3:4,2,1))" "slice out of range" \
+ "print sizeof non-allocated sliced vla1"

# Try to access value in allocated VLA
gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
gdb_continue_to_breakpoint "vla2-allocated"
gdb_test "print sizeof(vla1)" " = 4000" "print sizeof allocated vla1"
+gdb_test "print sizeof(vla1(3,2,1))" "4" "print sizeof non-allocated vla1"
+gdb_test "print sizeof(vla1(3:4,2,1))" "800" "print sizeof sliced vla1"

# Try to access values in undefined pointer to VLA (dangling)
gdb_breakpoint [gdb_get_line_number "vla1-filled"]
gdb_continue_to_breakpoint "vla1-filled"
gdb_test "print sizeof(pvla)" " = 0" "print sizeof non-associated pvla"
+gdb_test "print sizeof(pvla(3,2,1))" "no such vector element \\(vector not associated\\)" \
+ "print sizeof non-associated indexed pvla"
+gdb_test "print sizeof(pvla(3:4,2,1))" "slice out of range" \
+ "print sizeof non-associated sliced pvla"

# Try to access values in pointer to VLA and compare them
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_test "print sizeof(pvla(3,2,1))" "4" "print sizeof non-associated pvla"
+gdb_test "print sizeof(pvla(3:4,2,1))" "800" "print sizeof sliced pvla"

gdb_breakpoint [gdb_get_line_number "vla1-neg-bounds"]
gdb_continue_to_breakpoint "vla1-neg-bounds"

[Sebastian Basierski]

From: Bernhard Heckel <***@intel.com>

This patch changes the semantic of the Dwarf string length
attribute to reflect the standard as well as enables
correct string length calculation of dynamic strings. Add
tests for varous dynamic string evaluations.

Old:
(gdb) p my_dyn_string
Cannot access memory at address 0x605fc0

New:
(gdb) p *my_dyn_string
$1 = 'foo'

gdb/Changlog:
* dwarf2read.c (read_tag_string_type): changed
semantic of DW_AT_string_length to be able to
handle Dwarf blocks as well. Support for
DW_AT_byte_length added to get correct length
if specified in combination with
DW_AT_string_length.
(attr_to_dynamic_prop): added
functionality to add Dwarf operators to baton
data attribute. Added post values to baton
as required by the string evaluation case.
(read_subrange_type): Adapt caller.
(set_die_type): Adapt caller.
* gdbtypes.c (resolve_dynamic_type_internal): Handle
string types like array types.
(resolve_dynamic_array): Add conditions for dynamic
strings and create a new string type.
(is_dynamic_type_internal): Handle string types like
array types.

gdb/testsuite/Changelog:
* vla-strings.f90: New file.
* vla-strings.exp: New file.
---
gdb/dwarf2read.c | 153 ++++++++++++++++++----
gdb/gdbtypes.c | 15 ++-
gdb/testsuite/gdb.fortran/vla-strings.exp | 100 ++++++++++++++
gdb/testsuite/gdb.fortran/vla-strings.f90 | 39 ++++++
4 files changed, 274 insertions(+), 33 deletions(-)
create mode 100644 gdb/testsuite/gdb.fortran/vla-strings.exp
create mode 100644 gdb/testsuite/gdb.fortran/vla-strings.f90

diff --git a/gdb/dwarf2read.c b/gdb/dwarf2read.c
index 902aad3fbc..3e1965e5b4 100644
--- a/gdb/dwarf2read.c
+++ b/gdb/dwarf2read.c
@@ -1805,7 +1805,9 @@ static void read_signatured_type (struct signatured_type *);

static int attr_to_dynamic_prop (const struct attribute *attr,
struct die_info *die, struct dwarf2_cu *cu,
- struct dynamic_prop *prop);
+ struct dynamic_prop *prop,
+ const gdb_byte *additional_data,
+ int additional_data_size);

/* memory allocation interface */

@@ -13826,7 +13828,7 @@ read_func_scope (struct die_info *die, struct dwarf2_cu *cu)
{
newobj->static_link
= XOBNEW (&objfile->objfile_obstack, struct dynamic_prop);
- attr_to_dynamic_prop (attr, die, cu, newobj->static_link);
+ attr_to_dynamic_prop (attr, die, cu, newobj->static_link, nullptr, 0);
}

cu->list_in_scope = cu->builder->get_local_symbols ();
@@ -16584,7 +16586,8 @@ read_array_type (struct die_info *die, struct dwarf2_cu *cu)

byte_stride_prop
= (struct dynamic_prop *) alloca (sizeof (struct dynamic_prop));
- stride_ok = attr_to_dynamic_prop (attr, die, cu, byte_stride_prop);
+ stride_ok = attr_to_dynamic_prop (attr, die, cu, byte_stride_prop,
+ nullptr, 0);
if (!stride_ok)
{
complaint (_("unable to read array DW_AT_byte_stride "
@@ -17343,31 +17346,90 @@ read_tag_string_type (struct die_info *die, struct dwarf2_cu *cu)
{
struct objfile *objfile = cu->per_cu->dwarf2_per_objfile->objfile;
struct gdbarch *gdbarch = get_objfile_arch (objfile);
- struct type *type, *range_type, *index_type, *char_type;
+ struct type *type, *char_type;
struct attribute *attr;
- unsigned int length;
+ unsigned int length = UINT_MAX;
+
+ struct type *index_type = objfile_type (objfile)->builtin_int;
+ struct type *range_type = create_static_range_type (nullptr, index_type, 1, length);

+ /* If DW_AT_string_length is defined, the length is stored in memory. */
attr = dwarf2_attr (die, DW_AT_string_length, cu);
if (attr)
{
- length = DW_UNSND (attr);
+ if (attr_form_is_block (attr))
+ {
+ struct attribute *byte_size = dwarf2_attr (die, DW_AT_byte_size, cu);
+ struct attribute *bit_size = dwarf2_attr (die, DW_AT_bit_size, cu);
+ struct dynamic_prop high;
+
+ /* DW_AT_byte_size should never occur in combination with
+ DW_AT_bit_size. */
+ if (byte_size != nullptr && bit_size != nullptr)
+ complaint (_("DW_AT_byte_size AND "
+ "DW_AT_bit_size found together at the same time."));
+
+ /* If DW_AT_string_length AND DW_AT_byte_size exist together,
+ DW_AT_byte_size describes the number of bytes that should be read
+ from the length memory location. */
+ if (byte_size != nullptr)
+ {
+ /* Build new dwarf2_locexpr_baton structure with additions to the
+ data attribute, to reflect DWARF specialities to get address
+ sizes. */
+ const gdb_byte append_ops[] =
+ {
+ /* DW_OP_deref_size: size of an address on the target machine
+ (bytes), where the size will be specified by the next
+ operand. */
+ DW_OP_deref_size,
+ /* Operand for DW_OP_deref_size. */
+ gdb_byte (DW_UNSND (byte_size))
+ };
+
+ if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
+ ARRAY_SIZE(append_ops)))
+ complaint (_("Could not parse DW_AT_byte_size"));
+ }
+ else if (bit_size != NULL)
+ complaint (_("DW_AT_string_length AND "
+ "DW_AT_bit_size found but not supported yet."));
+ /* If DW_AT_string_length WITHOUT DW_AT_byte_size exist, the default
+ is the address size of the target machine. */
+ else
+ {
+ const gdb_byte append_ops[] = { DW_OP_deref };
+
+ if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
+ ARRAY_SIZE (append_ops)))
+ complaint (_("Could not parse DW_AT_string_length"));
+ }
+
+ TYPE_RANGE_DATA (range_type)->high = high;
+ }
+ else
+ {
+ TYPE_HIGH_BOUND (range_type) = DW_UNSND (attr);
+ TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
+ }
}
else
{
- /* Check for the DW_AT_byte_size attribute. */
+ /* Check for the DW_AT_byte_size attribute, which represents the length
+ in this case. */
attr = dwarf2_attr (die, DW_AT_byte_size, cu);
if (attr)
- {
- length = DW_UNSND (attr);
- }
+ {
+ TYPE_HIGH_BOUND (range_type) = DW_UNSND (attr);
+ TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
+ }
else
- {
- length = 1;
- }
+ {
+ TYPE_HIGH_BOUND (range_type) = 1;
+ TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
+ }
}

- index_type = objfile_type (objfile)->builtin_int;
- range_type = create_static_range_type (NULL, index_type, 1, length);
char_type = language_string_char_type (cu->language_defn, gdbarch);
type = create_string_type (NULL, char_type, range_type);

@@ -17735,7 +17797,8 @@ read_base_type (struct die_info *die, struct dwarf2_cu *cu)

static int
attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
- struct dwarf2_cu *cu, struct dynamic_prop *prop)
+ struct dwarf2_cu *cu, struct dynamic_prop *prop,
+ const gdb_byte *additional_data, int additional_data_size)
{
struct dwarf2_property_baton *baton;
struct obstack *obstack
@@ -17749,11 +17812,26 @@ attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
baton = XOBNEW (obstack, struct dwarf2_property_baton);
baton->referenced_type = NULL;
baton->locexpr.per_cu = cu->per_cu;
- baton->locexpr.size = DW_BLOCK (attr)->size;
- baton->locexpr.data = DW_BLOCK (attr)->data;
+
+ if (additional_data != nullptr && additional_data_size > 0)
+ {
+ gdb_byte *data = (gdb_byte *) obstack_alloc (obstack,
+ DW_BLOCK (attr)->size + additional_data_size);
+ memcpy (data, DW_BLOCK (attr)->data, DW_BLOCK (attr)->size);
+ memcpy (data + DW_BLOCK (attr)->size, additional_data,
+ additional_data_size);
+
+ baton->locexpr.data = data;
+ baton->locexpr.size = DW_BLOCK (attr)->size + additional_data_size;
+ }
+ else
+ {
+ baton->locexpr.data = DW_BLOCK (attr)->data;
+ baton->locexpr.size = DW_BLOCK (attr)->size;
+ }
+
prop->data.baton = baton;
prop->kind = PROP_LOCEXPR;
- gdb_assert (prop->data.baton != NULL);
}
else if (attr_form_is_ref (attr))
{
@@ -17786,11 +17864,28 @@ attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
baton = XOBNEW (obstack, struct dwarf2_property_baton);
baton->referenced_type = die_type (target_die, target_cu);
baton->locexpr.per_cu = cu->per_cu;
- baton->locexpr.size = DW_BLOCK (target_attr)->size;
- baton->locexpr.data = DW_BLOCK (target_attr)->data;
+
+ if (additional_data != NULL && additional_data_size > 0)
+ {
+ gdb_byte *data = (gdb_byte *) obstack_alloc (obstack,
+ DW_BLOCK (target_attr)->size + additional_data_size);
+ memcpy (data, DW_BLOCK (target_attr)->data,
+ DW_BLOCK (target_attr)->size);
+ memcpy (data + DW_BLOCK (target_attr)->size,
+ additional_data, additional_data_size);
+
+ baton->locexpr.data = data;
+ baton->locexpr.size = (DW_BLOCK (target_attr)->size
+ + additional_data_size);
+ }
+ else
+ {
+ baton->locexpr.data = DW_BLOCK (target_attr)->data;
+ baton->locexpr.size = DW_BLOCK (target_attr)->size;
+ }
+
prop->data.baton = baton;
prop->kind = PROP_LOCEXPR;
- gdb_assert (prop->data.baton != NULL);
}
else
{
@@ -17898,7 +17993,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)

attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
if (attr)
- if (!attr_to_dynamic_prop (attr, die, cu, &stride))
+ if (!attr_to_dynamic_prop (attr, die, cu, &stride, nullptr, 0))
complaint (_("Missing DW_AT_byte_stride "
"- DIE at 0x%s [in module %s]"),
sect_offset_str (die->sect_off),
@@ -17906,7 +18001,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)

attr = dwarf2_attr (die, DW_AT_lower_bound, cu);
if (attr)
- attr_to_dynamic_prop (attr, die, cu, &low);
+ attr_to_dynamic_prop (attr, die, cu, &low, nullptr, 0);
else if (!low_default_is_valid)
complaint (_("Missing DW_AT_lower_bound "
"- DIE at %s [in module %s]"),
@@ -17915,10 +18010,10 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)

struct attribute *attr_ub, *attr_count;
attr = attr_ub = dwarf2_attr (die, DW_AT_upper_bound, cu);
- if (!attr_to_dynamic_prop (attr, die, cu, &high))
+ if (!attr_to_dynamic_prop (attr, die, cu, &high, nullptr, 0))
{
attr = attr_count = dwarf2_attr (die, DW_AT_count, cu);
- if (attr_to_dynamic_prop (attr, die, cu, &high))
+ if (attr_to_dynamic_prop (attr, die, cu, &high, nullptr, 0))
{
/* If bounds are constant do the final calculation here. */
if (low.kind == PROP_CONST && high.kind == PROP_CONST)
@@ -25510,7 +25605,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
attr = dwarf2_attr (die, DW_AT_allocated, cu);
if (attr_form_is_block (attr))
{
- if (attr_to_dynamic_prop (attr, die, cu, &prop))
+ if (attr_to_dynamic_prop (attr, die, cu, &prop, nullptr, 0))
add_dyn_prop (DYN_PROP_ALLOCATED, prop, type);
}
else if (attr != NULL)
@@ -25524,7 +25619,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
attr = dwarf2_attr (die, DW_AT_associated, cu);
if (attr_form_is_block (attr))
{
- if (attr_to_dynamic_prop (attr, die, cu, &prop))
+ if (attr_to_dynamic_prop (attr, die, cu, &prop, nullptr, 0))
add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type);
}
else if (attr != NULL)
@@ -25536,7 +25631,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu)

/* Read DW_AT_data_location and set in type. */
attr = dwarf2_attr (die, DW_AT_data_location, cu);
- if (attr_to_dynamic_prop (attr, die, cu, &prop))
+ if (attr_to_dynamic_prop (attr, die, cu, &prop, nullptr, 0))
add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type);

if (dwarf2_per_objfile->die_type_hash == NULL)
diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
index 228b680a26..bb692caebf 100644
--- a/gdb/gdbtypes.c
+++ b/gdb/gdbtypes.c
@@ -1948,6 +1948,7 @@ is_dynamic_type_internal (struct type *type, int top_level)
}

case TYPE_CODE_ARRAY:
+ case TYPE_CODE_STRING:
{
gdb_assert (TYPE_NFIELDS (type) == 1);

@@ -2065,7 +2066,8 @@ resolve_dynamic_array (struct type *type,
struct dynamic_prop *prop;
unsigned int bit_stride = 0;

- gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
+ gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY
+ || TYPE_CODE (type) == TYPE_CODE_STRING);

type = copy_type (type);

@@ -2090,7 +2092,8 @@ resolve_dynamic_array (struct type *type,

ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));

- if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)
+ if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY
+ || TYPE_CODE (ary_dim) == TYPE_CODE_STRING))
elt_type = resolve_dynamic_array (ary_dim, addr_stack);
else
elt_type = TYPE_TARGET_TYPE (type);
@@ -2118,8 +2121,11 @@ resolve_dynamic_array (struct type *type,
else
bit_stride = TYPE_FIELD_BITSIZE (type, 0);

- return create_array_type_with_stride (type, elt_type, range_type, NULL,
- bit_stride);
+ if (TYPE_CODE (type) == TYPE_CODE_STRING)
+ return create_string_type (type, elt_type, range_type);
+ else
+ return create_array_type_with_stride (type, elt_type, range_type,
+ nullptr, bit_stride);
}

/* Resolve dynamic bounds of members of the union TYPE to static
@@ -2324,6 +2330,7 @@ resolve_dynamic_type_internal (struct type *type,
break;

case TYPE_CODE_ARRAY:
+ case TYPE_CODE_STRING:
resolved_type = resolve_dynamic_array (type, addr_stack);
break;

diff --git a/gdb/testsuite/gdb.fortran/vla-strings.exp b/gdb/testsuite/gdb.fortran/vla-strings.exp
new file mode 100644
index 0000000000..be9107514c
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-strings.exp
@@ -0,0 +1,100 @@
+# Copyright 2018 Free Software Foundation, Inc.
+
+# This program is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+standard_testfile ".f90"
+
+if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
+ {debug f90 quiet}] } {
+ return -1
+}
+
+if ![runto_main] {
+ untested "could not run to main"
+ return -1
+}
+
+gdb_breakpoint [gdb_get_line_number "var_char-allocated-1"]
+gdb_continue_to_breakpoint "var_char-allocated-1"
+set test "whatis var_char first time"
+gdb_test_multiple "whatis var_char" $test {
+ -re "type = PTR TO -> \\( character\\*10 \\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "type = character\\*10\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+set test "ptype var_char first time"
+gdb_test_multiple "ptype var_char" $test {
+ -re "type = PTR TO -> \\( character\\*10 \\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "type = character\\*10\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+
+
+gdb_test "next" "\\d+.*var_char = 'foo'.*" \
+ "next to allocation status of var_char"
+gdb_test "print l" " = \\.TRUE\\." "print allocation status first time"
+
+
+gdb_breakpoint [gdb_get_line_number "var_char-filled-1"]
+gdb_continue_to_breakpoint "var_char-filled-1"
+set test "print var_char, var_char-filled-1"
+gdb_test_multiple "print var_char" $test {
+ -re "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\r\n$gdb_prompt $" {
+ gdb_test "print *var_char" "= 'foo'" "print *var_char, var_char-filled-1"
+ pass $test
+ }
+ -re "= 'foo'\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+set test "ptype var_char, var_char-filled-1"
+gdb_test_multiple "ptype var_char" $test {
+ -re "type = PTR TO -> \\( character\\*3 \\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "type = character\\*3\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+gdb_test "print var_char(1)" " = 102" "print var_char(1)"
+gdb_test "print var_char(3)" " = 111" "print var_char(3)"
+
+
+gdb_breakpoint [gdb_get_line_number "var_char-filled-2"]
+gdb_continue_to_breakpoint "var_char-filled-2"
+set test "print var_char, var_char-filled-2"
+gdb_test_multiple "print var_char" $test {
+ -re "= \\(PTR TO -> \\( character\\*6 \\)\\) $hex\r\n$gdb_prompt $" {
+ gdb_test "print *var_char" "= 'foobar'" "print *var_char, var_char-filled-2"
+ pass $test
+ }
+ -re "= 'foobar'\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
+set test "ptype var_char, var_char-filled-2"
+gdb_test_multiple "ptype var_char" $test {
+ -re "type = PTR TO -> \\( character\\*6 \\)\r\n$gdb_prompt $" {
+ pass $test
+ }
+ -re "type = character\\*6\r\n$gdb_prompt $" {
+ pass $test
+ }
+}
diff --git a/gdb/testsuite/gdb.fortran/vla-strings.f90 b/gdb/testsuite/gdb.fortran/vla-strings.f90
new file mode 100644
index 0000000000..5d393f9f40
--- /dev/null
+++ b/gdb/testsuite/gdb.fortran/vla-strings.f90
@@ -0,0 +1,39 @@
+! Copyright 2018 Free Software Foundation, Inc.
+!
+! This program is free software; you can redistribute it and/or modify
+! it under the terms of the GNU General Public License as published by
+! the Free Software Foundation; either version 3 of the License, or
+! (at your option) any later version.
+!
+! This program is distributed in the hope that it will be useful,
+! but WITHOUT ANY WARRANTY; without even the implied warranty of
+! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+! GNU General Public License for more details.
+!
+! You should have received a copy of the GNU General Public License
+! along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+program vla_strings
+ character(len=:), target, allocatable :: var_char
+ character(len=:), pointer :: var_char_p
+ logical :: l
+
+ allocate(character(len=10) :: var_char)
+ l = allocated(var_char) ! var_char-allocated-1
+ var_char = 'foo'
+ deallocate(var_char) ! var_char-filled-1
+ l = allocated(var_char) ! var_char-deallocated
+ allocate(character(len=42) :: var_char)
+ l = allocated(var_char)
+ var_char = 'foobar'
+ var_char = '' ! var_char-filled-2
+ var_char = 'bar' ! var_char-empty
+ deallocate(var_char)
+ allocate(character(len=21) :: var_char)
+ l = allocated(var_char) ! var_char-allocated-3
+ var_char = 'johndoe'
+ var_char_p => var_char
+ l = associated(var_char_p) ! var_char_p-associated
+ var_char_p => null()
+ l = associated(var_char_p) ! var_char_p-not-associated
+end program vla_strings