[PATCH 00/23] Fortran dynamic array support
https://sourceware.org/ml/gdb-patches/2014-06/msg00108.html
https://github.com/intel-gdb/vla/tree/vla-fortran
GIT snapshot:
commit 511bff520372ffc10fa2ff569c176bdf1e6e475d
Index: gdb-7.10.50.20160106/gdb/c-valprint.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/c-valprint.c 2016-01-08 19:15:35.065582359 +0100
+++ gdb-7.10.50.20160106/gdb/c-valprint.c 2016-01-08 19:15:44.974637630 +0100
@@ -642,7 +642,16 @@
{
/* normal case */
fprintf_filtered (stream, "(");
- type_print (value_type (val), "", stream, -1);
+ if (is_dynamic_type (TYPE_TARGET_TYPE (type)))
+ {
+ struct value *v;
+
+ v = value_ind (val);
+ v = value_addr (v);
+ type_print (value_type (v), "", stream, -1);
+ }
+ else
+ type_print (value_type (val), "", stream, -1);
fprintf_filtered (stream, ") ");
}
}
Index: gdb-7.10.50.20160106/gdb/dwarf2loc.h
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/dwarf2loc.h 2016-01-08 19:15:35.066582365 +0100
+++ gdb-7.10.50.20160106/gdb/dwarf2loc.h 2016-01-08 19:15:44.974637630 +0100
@@ -138,6 +138,11 @@
struct property_addr_info *addr_stack,
CORE_ADDR *value);
+/* Checks if a dwarf location definition is valid.
+ Returns 1 if valid; 0 otherwise. */
+
+extern int dwarf2_address_data_valid (const struct type *type);
+
/* A helper for the compiler interface that compiles a single dynamic
property to C code.
Index: gdb-7.10.50.20160106/gdb/dwarf2read.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/dwarf2read.c 2016-01-08 19:15:35.078582432 +0100
+++ gdb-7.10.50.20160106/gdb/dwarf2read.c 2016-01-08 19:15:44.980637663 +0100
@@ -1745,7 +1745,9 @@
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 */
@@ -11420,7 +11422,7 @@
{
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, NULL, 0);
}
cu->list_in_scope = &local_symbols;
@@ -14471,29 +14473,92 @@
struct gdbarch *gdbarch = get_objfile_arch (objfile);
struct type *type, *range_type, *index_type, *char_type;
struct attribute *attr;
- unsigned int length;
+ unsigned int length = UINT_MAX;
+ index_type = objfile_type (objfile)->builtin_int;
+ range_type = create_static_range_type (NULL, index_type, 1, length);
+
+ /* If DW_AT_string_length is defined, the length is stored at some location
+ * 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, *bit_size;
+ struct dynamic_prop high;
+
+ byte_size = dwarf2_attr (die, DW_AT_byte_size, cu);
+ bit_size = dwarf2_attr (die, DW_AT_bit_size, cu);
+
+ /* DW_AT_byte_size should never occur together in combination with
+ DW_AT_string_length. */
+ if ((byte_size == NULL && bit_size != NULL) ||
+ (byte_size != NULL && bit_size == NULL))
+ complaint (&symfile_complaints, _("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, it
+ describes the number of bytes that should be read from the length
+ memory location. */
+ if (byte_size != NULL && bit_size == NULL)
+ {
+ /* 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. */
+ DW_UNSND (byte_size) };
+
+ if (!attr_to_dynamic_prop (attr, die, cu, &high,
+ append_ops, ARRAY_SIZE (append_ops)))
+ complaint (&symfile_complaints,
+ _("Could not parse DW_AT_byte_size"));
+ }
+ else if (bit_size != NULL && byte_size == NULL)
+ complaint (&symfile_complaints, _("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 (&symfile_complaints,
+ _("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);
@@ -14816,13 +14881,15 @@
return set_die_type (die, type, cu);
}
+
/* Parse dwarf attribute if it's a block, reference or constant and put the
resulting value of the attribute into struct bound_prop.
Returns 1 if ATTR could be resolved into PROP, 0 otherwise. */
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 = &cu->objfile->objfile_obstack;
@@ -14835,8 +14902,25 @@
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 != NULL && additional_data_size > 0)
+ {
+ gdb_byte *data;
+
+ data = obstack_alloc (&cu->objfile->objfile_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);
@@ -14872,8 +14956,28 @@
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;
+
+ data = obstack_alloc (&cu->objfile->objfile_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);
@@ -14927,7 +15031,7 @@
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;
@@ -14947,7 +15051,9 @@
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. */
@@ -14980,19 +15086,26 @@
break;
}
+ attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
+ if (attr)
+ if (!attr_to_dynamic_prop (attr, die, cu, &stride, NULL, 0))
+ complaint (&symfile_complaints, _("Missing DW_AT_byte_stride "
+ "- DIE at 0x%x [in module %s]"),
+ die->offset.sect_off, objfile_name (cu->objfile));
+
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, NULL, 0);
else if (!low_default_is_valid)
complaint (&symfile_complaints, _("Missing DW_AT_lower_bound "
"- DIE at 0x%x [in module %s]"),
die->offset.sect_off, objfile_name (cu->objfile));
attr = 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, NULL, 0))
{
attr = 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, NULL, 0))
{
/* If bounds are constant do the final calculation here. */
if (low.kind == PROP_CONST && high.kind == PROP_CONST)
@@ -15056,7 +15169,7 @@
&& !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;
@@ -22360,7 +22473,7 @@
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, NULL, 0))
add_dyn_prop (DYN_PROP_ALLOCATED, prop, type, objfile);
}
else if (attr != NULL)
@@ -22375,7 +22488,7 @@
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, NULL, 0))
add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type, objfile);
}
else if (attr != NULL)
@@ -22388,7 +22501,7 @@
/* 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, NULL, 0))
add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type, objfile);
if (dwarf2_per_objfile->die_type_hash == NULL)
Index: gdb-7.10.50.20160106/gdb/f-typeprint.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/f-typeprint.c 2016-01-08 19:15:35.080582443 +0100
+++ gdb-7.10.50.20160106/gdb/f-typeprint.c 2016-01-08 19:15:44.980637663 +0100
@@ -31,6 +31,7 @@
#include "target.h"
#include "f-lang.h"
#include "typeprint.h"
+#include "valprint.h"
#if 0 /* Currently unused. */
static void f_type_print_args (struct type *, struct ui_file *);
@@ -64,6 +65,17 @@
{
val_print_not_allocated (stream);
return;
+ }
+
+ 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);
Index: gdb-7.10.50.20160106/gdb/f-valprint.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/f-valprint.c 2016-01-08 19:15:35.081582448 +0100
+++ gdb-7.10.50.20160106/gdb/f-valprint.c 2016-01-08 19:15:44.981637669 +0100
@@ -36,8 +36,6 @@
extern void _initialize_f_valprint (void);
static void info_common_command (char *, int);
-static void f77_create_arrayprint_offset_tbl (struct type *,
- struct ui_file *);
static void f77_get_dynamic_length_of_aggregate (struct type *);
int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
@@ -45,15 +43,6 @@
/* Array which holds offsets to be applied to get a row's elements
for a given array. Array also holds the size of each subarray. */
-/* The following macro gives us the size of the nth dimension, Where
- n is 1 based. */
-
-#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
-
-/* The following gives us the offset for row n where n is 1-based. */
-
-#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
-
int
f77_get_lowerbound (struct type *type)
{
@@ -111,47 +100,6 @@
* TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
}
-/* Function that sets up the array offset,size table for the array
- type "type". */
-
-static void
-f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
-{
- struct type *tmp_type;
- int eltlen;
- int ndimen = 1;
- int upper, lower;
-
- tmp_type = type;
-
- while (TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)
- {
- upper = f77_get_upperbound (tmp_type);
- lower = f77_get_lowerbound (tmp_type);
-
- F77_DIM_SIZE (ndimen) = upper - lower + 1;
-
- tmp_type = TYPE_TARGET_TYPE (tmp_type);
- ndimen++;
- }
-
- /* Now we multiply eltlen by all the offsets, so that later we
- can print out array elements correctly. Up till now we
- know an offset to apply to get the item but we also
- have to know how much to add to get to the next item. */
-
- ndimen--;
- eltlen = TYPE_LENGTH (tmp_type);
- F77_DIM_OFFSET (ndimen) = eltlen;
- while (--ndimen > 0)
- {
- eltlen *= F77_DIM_SIZE (ndimen + 1);
- F77_DIM_OFFSET (ndimen) = eltlen;
- }
-}
-
-
-
/* Actual function which prints out F77 arrays, Valaddr == address in
the superior. Address == the address in the inferior. */
@@ -164,41 +112,62 @@
const struct value_print_options *options,
int *elts)
{
+ struct type *range_type = TYPE_INDEX_TYPE (check_typedef (type));
+ CORE_ADDR addr = address + embedded_offset;
+ LONGEST lowerbound, upperbound;
int i;
+ get_discrete_bounds (range_type, &lowerbound, &upperbound);
+
if (nss != ndimensions)
{
- for (i = 0;
- (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max);
+ 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);
i++)
{
+ struct value *subarray = value_from_contents_and_address
+ (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val)
+ + offs, addr + offs);
+
fprintf_filtered (stream, "( ");
- f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
- valaddr,
- embedded_offset + i * F77_DIM_OFFSET (nss),
- address,
- stream, recurse, val, options, elts);
+ f77_print_array_1 (nss + 1, ndimensions, value_type (subarray),
+ value_contents_for_printing (subarray),
+ value_embedded_offset (subarray),
+ value_address (subarray),
+ stream, recurse, subarray, options, elts);
+ offs += dim_size;
fprintf_filtered (stream, ") ");
}
- if (*elts >= options->print_max && i < F77_DIM_SIZE (nss))
+ if (*elts >= options->print_max && i < upperbound)
fprintf_filtered (stream, "...");
}
else
{
- for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < options->print_max;
+ for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;
i++, (*elts)++)
{
- val_print (TYPE_TARGET_TYPE (type),
- valaddr,
- embedded_offset + i * F77_DIM_OFFSET (ndimensions),
- address, stream, recurse,
- val, options, current_language);
+ struct value *elt = value_subscript ((struct value *)val, i);
+
+ val_print (value_type (elt),
+ value_contents_for_printing (elt),
+ value_embedded_offset (elt),
+ value_address (elt), stream, recurse,
+ elt, options, current_language);
- if (i != (F77_DIM_SIZE (nss) - 1))
+ if (i != upperbound)
fprintf_filtered (stream, ", ");
if ((*elts == options->print_max - 1)
- && (i != (F77_DIM_SIZE (nss) - 1)))
+ && (i != upperbound))
fprintf_filtered (stream, "...");
}
}
@@ -225,12 +194,6 @@
Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
ndimensions, MAX_FORTRAN_DIMS);
- /* Since F77 arrays are stored column-major, we set up an
- offset table to get at the various row's elements. The
- offset table contains entries for both offset and subarray size. */
-
- f77_create_arrayprint_offset_tbl (type, stream);
-
f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
address, stream, recurse, val, options, &elts);
}
@@ -375,12 +338,15 @@
fprintf_filtered (stream, "( ");
for (index = 0; index < TYPE_NFIELDS (type); index++)
{
- int offset = TYPE_FIELD_BITPOS (type, index) / 8;
+ struct value *field = value_field
+ ((struct value *)original_value, index);
+
+ val_print (value_type (field),
+ value_contents_for_printing (field),
+ value_embedded_offset (field),
+ value_address (field), stream, recurse + 1,
+ field, options, current_language);
- val_print (TYPE_FIELD_TYPE (type, index), valaddr,
- embedded_offset + offset,
- address, stream, recurse + 1,
- original_value, options, current_language);
if (index != TYPE_NFIELDS (type) - 1)
fputs_filtered (", ", stream);
}
Index: gdb-7.10.50.20160106/gdb/gdbtypes.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/gdbtypes.c 2016-01-08 19:15:35.083582459 +0100
+++ gdb-7.10.50.20160106/gdb/gdbtypes.c 2016-01-08 19:15:44.982637674 +0100
@@ -836,7 +836,8 @@
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);
@@ -851,6 +852,7 @@
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;
@@ -879,7 +881,7 @@
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;
@@ -887,7 +889,11 @@
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;
}
@@ -1084,16 +1090,21 @@
&& (!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;
@@ -1804,12 +1815,31 @@
static int
is_dynamic_type_internal (struct type *type, int top_level)
{
+ int index;
+
+ if (!type)
+ return 0;
+
type = check_typedef (type);
/* We only want to recognize references at the outermost level. */
if (top_level && TYPE_CODE (type) == TYPE_CODE_REF)
type = check_typedef (TYPE_TARGET_TYPE (type));
+ if (TYPE_ASSOCIATED_PROP (type))
+ return 1;
+
+ if (TYPE_ALLOCATED_PROP (type))
+ return 1;
+
+ /* Scan field types in the Fortran case for nested dynamic types.
+ This will be done only for Fortran as in the C++ case an endless recursion
+ can occur in the area of classes. */
+ if (current_language->la_language == language_fortran)
+ for (index = 0; index < TYPE_NFIELDS (type); index++)
+ if (is_dynamic_type (TYPE_FIELD_TYPE (type, index)))
+ return 1;
+
/* Types that have a dynamic TYPE_DATA_LOCATION are considered
dynamic, even if the type itself is statically defined.
From a user's point of view, this may appear counter-intuitive;
@@ -1844,11 +1874,19 @@
{
gdb_assert (TYPE_NFIELDS (type) == 1);
- /* The array is dynamic if either the bounds are dynamic,
- or the elements it contains have a dynamic contents. */
+ /* The array is dynamic if either
+ - the bounds are dynamic,
+ - the elements it contains have a dynamic contents
+ - a data_locaton attribute was found. */
if (is_dynamic_type_internal (TYPE_INDEX_TYPE (type), 0))
return 1;
- return is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0);
+ else if (TYPE_DATA_LOCATION (type) != NULL
+ && (TYPE_DATA_LOCATION_KIND (type) == PROP_LOCEXPR
+ || TYPE_DATA_LOCATION_KIND (type) == PROP_LOCLIST))
+ return 1;
+ else
+ return is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0);
+ break;
}
case TYPE_CODE_STRUCT:
@@ -1861,6 +1899,18 @@
&& is_dynamic_type_internal (TYPE_FIELD_TYPE (type, i), 0))
return 1;
}
+ case TYPE_CODE_PTR:
+ {
+ if (TYPE_TARGET_TYPE (type)
+ && (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING
+ || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY))
+ return is_dynamic_type (check_typedef (TYPE_TARGET_TYPE (type)));
+
+ return 0;
+ break;
+ }
+ default:
+ return 0;
break;
}
@@ -1890,7 +1940,8 @@
struct type *static_range_type, *static_target_type;
const struct dynamic_prop *prop;
const struct dwarf2_locexpr_baton *baton;
- struct dynamic_prop low_bound, high_bound;
+ struct dynamic_prop low_bound, high_bound, stride;
+ struct type *range_copy = copy_type (dyn_range_type);
gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE);
@@ -1922,12 +1973,19 @@
high_bound.data.const_val = 0;
}
+ prop = &TYPE_RANGE_DATA (dyn_range_type)->stride;
+ if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
+ {
+ stride.kind = PROP_CONST;
+ stride.data.const_val = value;
+ }
+
static_target_type
- = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (dyn_range_type),
+ = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (range_copy),
addr_stack, 0);
- static_range_type = create_range_type (copy_type (dyn_range_type),
+ static_range_type = create_range_type (range_copy,
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;
}
@@ -1946,7 +2004,8 @@
struct type *ary_dim;
struct dynamic_prop *prop;
- 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);
@@ -1971,13 +2030,18 @@
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);
- return create_array_type_with_stride (type, elt_type, range_type,
- TYPE_FIELD_BITSIZE (type, 0));
+ if (TYPE_CODE (type) == TYPE_CODE_STRING
+ && TYPE_FIELD_BITSIZE (type, 0) == 0)
+ return create_string_type (type, elt_type, range_type);
+ else
+ return create_array_type_with_stride (type, elt_type, range_type,
+ TYPE_FIELD_BITSIZE (type, 0));
}
/* Resolve dynamic bounds of members of the union TYPE to static
Index: gdb-7.10.50.20160106/gdb/gdbtypes.h
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/gdbtypes.h 2016-01-08 19:15:35.085582471 +0100
+++ gdb-7.10.50.20160106/gdb/gdbtypes.h 2016-01-08 19:15:44.983637680 +0100
@@ -577,6 +577,10 @@
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. */
@@ -749,6 +753,18 @@
/* * Contains all dynamic type properties. */
struct dynamic_prop_list *dyn_prop_list;
+
+ /* Structure for DW_AT_allocated.
+ The presence of this attribute indicates that the object of the type
+ can be allocated/deallocated. The value can be a dwarf expression,
+ reference, or a constant. */
+ struct dynamic_prop *allocated;
+
+ /* Structure for DW_AT_associated.
+ The presence of this attribute indicated that the object of the type
+ can be associated. The value can be a dwarf expression,
+ reference, or a constant. */
+ struct dynamic_prop *associated;
};
/* * A ``struct type'' describes a particular instance of a type, with
@@ -1255,6 +1271,15 @@
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) \
@@ -1266,6 +1291,18 @@
#define TYPE_DATA_LOCATION_KIND(thistype) \
TYPE_DATA_LOCATION (thistype)->kind
+/* Allocated status of type object. If set to non-zero it means the object
+ is allocated. A zero value means it is not allocated. */
+#define TYPE_NOT_ALLOCATED(t) (TYPE_ALLOCATED_PROP (t) \
+ && TYPE_ALLOCATED_PROP (t)->kind == PROP_CONST \
+ && !TYPE_ALLOCATED_PROP (t)->data.const_val)
+
+/* Associated status of type object. If set to non-zero it means the object
+ is associated. A zero value means it is not associated. */
+#define TYPE_NOT_ASSOCIATED(t) (TYPE_ASSOCIATED_PROP (t) \
+ && TYPE_ASSOCIATED_PROP (t)->kind == PROP_CONST \
+ && !TYPE_ASSOCIATED_PROP (t)->data.const_val)
+
/* Property accessors for the type allocated/associated. */
#define TYPE_ALLOCATED_PROP(thistype) \
get_dyn_prop (DYN_PROP_ALLOCATED, thistype)
@@ -1289,6 +1326,9 @@
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))))
@@ -1775,6 +1815,7 @@
extern struct type *create_range_type (struct type *, struct type *,
const struct dynamic_prop *,
+ const struct dynamic_prop *,
const struct dynamic_prop *);
extern struct type *create_array_type (struct type *, struct type *,
Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.exp 2016-01-08 19:15:44.983637680 +0100
@@ -0,0 +1,61 @@
+# Copyright 2014 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
+}
+
+# Check VLA passed to first Fortran function.
+gdb_breakpoint [gdb_get_line_number "func1-vla-passed"]
+gdb_continue_to_breakpoint "func1-vla-passed"
+gdb_test "print vla" " = \\( *\\( *22, *22, *22,\[()22, .\]*\\)" \
+ "print vla (func1)"
+gdb_test "ptype vla" "type = integer\\\(kind=4\\\) \\\(10,10\\\)" \
+ "ptype vla (func1)"
+
+gdb_breakpoint [gdb_get_line_number "func1-vla-modified"]
+gdb_continue_to_breakpoint "func1-vla-modified"
+gdb_test "print vla(5,5)" " = 55" "print vla(5,5) (func1)"
+gdb_test "print vla(7,7)" " = 77" "print vla(5,5) (func1)"
+
+# Check if the values are correct after returning from func1
+gdb_breakpoint [gdb_get_line_number "func1-returned"]
+gdb_continue_to_breakpoint "func1-returned"
+gdb_test "print ret" " = .TRUE." "print ret after func1 returned"
+
+# Check VLA passed to second Fortran function
+gdb_breakpoint [gdb_get_line_number "func2-vla-passed"]
+gdb_continue_to_breakpoint "func2-vla-passed"
+gdb_test "print vla" \
+ " = \\\(44, 44, 44, 44, 44, 44, 44, 44, 44, 44\\\)" \
+ "print vla (func2)"
+gdb_test "ptype vla" "type = integer\\\(kind=4\\\) \\\(10\\\)" \
+ "ptype vla (func2)"
+
+# Check if the returned VLA has the correct values and ptype.
+gdb_breakpoint [gdb_get_line_number "func2-returned"]
+gdb_continue_to_breakpoint "func2-returned"
+gdb_test "print vla3" " = \\\(1, 2, 44, 4, 44, 44, 44, 8, 44, 44\\\)" \
+ "print vla3 (after func2)"
+gdb_test "ptype vla3" "type = integer\\\(kind=4\\\) \\\(10\\\)" \
+ "ptype vla3 (after func2)"
Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.f90 2016-01-08 19:15:44.983637680 +0100
@@ -0,0 +1,71 @@
+! Copyright 2014 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 2 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, write to the Free Software
+! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+logical function func1 (vla)
+ implicit none
+ integer, allocatable :: vla (:, :)
+ func1 = allocated(vla)
+ vla(5,5) = 55 ! func1-vla-passed
+ vla(7,7) = 77
+ return ! func1-vla-modified
+end function func1
+
+function func2(vla)
+ implicit none
+ integer :: vla (:)
+ integer :: func2(size(vla))
+ integer :: k
+
+ vla(1) = 1 ! func2-vla-passed
+ vla(2) = 2
+ vla(4) = 4
+ vla(8) = 8
+
+ func2 = vla
+end function func2
+
+program vla_func
+ implicit none
+ interface
+ logical function func1 (vla)
+ integer :: vla (:, :)
+ end function
+ end interface
+ interface
+ function func2 (vla)
+ integer :: vla (:)
+ integer func2(size(vla))
+ end function
+ end interface
+
+ logical :: ret
+ integer, allocatable :: vla1 (:, :)
+ integer, allocatable :: vla2 (:)
+ integer, allocatable :: vla3 (:)
+
+ ret = .FALSE.
+
+ allocate (vla1 (10,10))
+ vla1(:,:) = 22
+
+ allocate (vla2 (10))
+ vla2(:) = 44
+
+ ret = func1(vla1)
+ vla3 = func2(vla2) ! func1-returned
+
+ ret = .TRUE. ! func2-returned
+end program vla_func
Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-stride.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-stride.exp 2016-01-08 19:15:44.984637686 +0100
@@ -0,0 +1,44 @@
+# Copyright 2014 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"
Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-stride.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-stride.f90 2016-01-08 19:15:44.984637686 +0100
@@ -0,0 +1,30 @@
+! Copyright 2014 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 2 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, write to the Free Software
+! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+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
Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-strings.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-strings.exp 2016-01-08 19:15:44.984637686 +0100
@@ -0,0 +1,101 @@
+# Copyright 2014 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
+}
+
+# check that all fortran standard datatypes will be
+# handled correctly when using as VLA's
+
+if ![runto MAIN__] then {
+ perror "couldn't run to breakpoint MAIN__"
+ continue
+}
+
+gdb_breakpoint [gdb_get_line_number "var_char-allocated-1"]
+gdb_continue_to_breakpoint "var_char-allocated-1"
+gdb_test "print var_char" \
+ " = \\(PTR TO -> \\( character\\*10 \\)\\) ${hex}" \
+ "print var_char after allocated first time"
+gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*10 \\)" \
+ "whatis var_char first time"
+gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*10 \\)" \
+ "ptype var_char first time"
+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"
+gdb_test "print var_char" \
+ " = \\(PTR TO -> \\( character\\*3 \\)\\) ${hex}" \
+ "print var_char after filled first time"
+gdb_test "print *var_char" " = 'foo'" \
+ "print *var_char after filled first time"
+gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*3 \\)" \
+ "whatis var_char after filled first time"
+gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*3 \\)" \
+ "ptype var_char after filled first time"
+gdb_test "print var_char(1)" " = 102 'f'" "print var_char(1)"
+gdb_test "print var_char(3)" " = 111 'o'" "print var_char(3)"
+
+gdb_breakpoint [gdb_get_line_number "var_char-filled-2"]
+gdb_continue_to_breakpoint "var_char-filled-2"
+gdb_test "print var_char" \
+ " = \\(PTR TO -> \\( character\\*6 \\)\\) ${hex}" \
+ "print var_char after allocated second time"
+gdb_test "print *var_char" " = 'foobar'" \
+ "print *var_char after allocated second time"
+gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*6 \\)" \
+ "whatis var_char second time"
+gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*6 \\)" \
+ "ptype var_char second time"
+
+gdb_breakpoint [gdb_get_line_number "var_char-empty"]
+gdb_continue_to_breakpoint "var_char-empty"
+gdb_test "print var_char" \
+ " = \\(PTR TO -> \\( character\\*0 \\)\\) ${hex}" \
+ "print var_char after set empty"
+gdb_test "print *var_char" " = \"\"" "print *var_char after set empty"
+gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*0 \\)" \
+ "whatis var_char after set empty"
+gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*0 \\)" \
+ "ptype var_char after set empty"
+
+gdb_breakpoint [gdb_get_line_number "var_char-allocated-3"]
+gdb_continue_to_breakpoint "var_char-allocated-3"
+gdb_test "print var_char" \
+ " = \\(PTR TO -> \\( character\\*21 \\)\\) ${hex}" \
+ "print var_char after allocated third time"
+gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*21 \\)" \
+ "whatis var_char after allocated third time"
+gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*21 \\)" \
+ "ptype var_char after allocated third time"
+
+gdb_breakpoint [gdb_get_line_number "var_char_p-associated"]
+gdb_continue_to_breakpoint "var_char_p-associated"
+gdb_test "print var_char_p" \
+ " = \\(PTR TO -> \\( character\\*7 \\)\\) ${hex}" \
+ "print var_char_p after associated"
+gdb_test "print *var_char_p" " = 'johndoe'" \
+ "print *var_char_ after associated"
+gdb_test "whatis var_char_p" "type = PTR TO -> \\( character\\*7 \\)" \
+ "whatis var_char_p after associated"
+gdb_test "ptype var_char_p" "type = PTR TO -> \\( character\\*7 \\)" \
+ "ptype var_char_p after associated"
Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-strings.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-strings.f90 2016-01-08 19:15:44.984637686 +0100
@@ -0,0 +1,40 @@
+! Copyright 2014 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 2 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, write to the Free Software
+! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+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
Index: gdb-7.10.50.20160106/gdb/typeprint.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/typeprint.c 2016-01-08 19:15:35.086582476 +0100
+++ gdb-7.10.50.20160106/gdb/typeprint.c 2016-01-08 19:15:44.984637686 +0100
@@ -460,6 +460,13 @@
type = value_type (val);
+ if (TYPE_CODE (type) == TYPE_CODE_PTR)
+ if (is_dynamic_type (TYPE_TARGET_TYPE (type)))
+ {
+ val = value_addr (value_ind (val));
+ type = value_type (val);
+ }
+
get_user_print_options (&opts);
if (opts.objectprint)
{
Index: gdb-7.10.50.20160106/gdb/valarith.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/valarith.c 2016-01-08 19:15:35.087582482 +0100
+++ gdb-7.10.50.20160106/gdb/valarith.c 2016-01-08 19:15:44.985637691 +0100
@@ -193,9 +193,21 @@
struct type *array_type = check_typedef (value_type (array));
struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (array_type));
unsigned int elt_size = type_length_units (elt_type);
- unsigned int elt_offs = elt_size * longest_to_int (index - lowerbound);
+ unsigned int elt_offs = longest_to_int (index - lowerbound);
+ LONGEST elt_stride = TYPE_BYTE_STRIDE (TYPE_INDEX_TYPE (array_type));
struct value *v;
+ if (elt_stride > 0)
+ elt_offs *= elt_stride;
+ else if (elt_stride < 0)
+ {
+ int offs = (elt_offs + 1) * elt_stride;
+
+ elt_offs = TYPE_LENGTH (array_type) + offs;
+ }
+ else
+ elt_offs *= elt_size;
+
if (index < lowerbound || (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)
&& elt_offs >= type_length_units (array_type)))
{
Index: gdb-7.10.50.20160106/gdb/valprint.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/valprint.c 2016-01-08 19:15:35.088582487 +0100
+++ gdb-7.10.50.20160106/gdb/valprint.c 2016-01-08 19:15:44.986637697 +0100
@@ -316,6 +316,18 @@
return 0;
}
+ if (TYPE_NOT_ASSOCIATED (type))
+ {
+ val_print_not_associated (stream);
+ return 0;
+ }
+
+ if (TYPE_NOT_ALLOCATED (type))
+ {
+ val_print_not_allocated (stream);
+ return 0;
+ }
+
if (TYPE_CODE (type) != TYPE_CODE_UNION
&& TYPE_CODE (type) != TYPE_CODE_STRUCT
&& TYPE_CODE (type) != TYPE_CODE_ARRAY)
@@ -1025,12 +1037,16 @@
value_check_printable (struct value *val, struct ui_file *stream,
const struct value_print_options *options)
{
+ const struct type *type;
+
if (val == 0)
{
fprintf_filtered (stream, _("<address of value unknown>"));
return 0;
}
+ type = value_type (val);
+
if (value_entirely_optimized_out (val))
{
if (options->summary && !val_print_scalar_type_p (value_type (val)))
@@ -1066,6 +1082,18 @@
{
val_print_not_allocated (stream);
return 0;
+ }
+
+ if (TYPE_NOT_ASSOCIATED (type))
+ {
+ val_print_not_associated (stream);
+ return 0;
+ }
+
+ if (TYPE_NOT_ALLOCATED (type))
+ {
+ val_print_not_allocated (stream);
+ return 0;
}
return 1;
Index: gdb-7.10.50.20160106/gdb/valprint.h
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/valprint.h 2016-01-08 19:15:35.088582487 +0100
+++ gdb-7.10.50.20160106/gdb/valprint.h 2016-01-08 19:15:44.986637697 +0100
@@ -232,4 +232,8 @@
struct format_data *fmtp);
extern void print_value (struct value *val, const struct format_data *fmtp);
+extern void val_print_not_allocated (struct ui_file *stream);
+
+extern void val_print_not_associated (struct ui_file *stream);
+
#endif
Index: gdb-7.10.50.20160106/gdb/value.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/value.c 2016-01-08 19:15:35.090582499 +0100
+++ gdb-7.10.50.20160106/gdb/value.c 2016-01-08 19:15:44.987637702 +0100
@@ -40,6 +40,7 @@
#include "tracepoint.h"
#include "cp-abi.h"
#include "user-regs.h"
+#include "dwarf2loc.h"
/* Prototypes for exported functions. */
@@ -1788,6 +1789,25 @@
if (funcs->copy_closure)
component->location.computed.closure = funcs->copy_closure (whole);
}
+
+ /* For dynamic types compute the address of the component value location in
+ sub range types based on the location of the sub range type, if not being
+ an internal GDB variable or parts of it. */
+ if (VALUE_LVAL (component) != lval_internalvar
+ && VALUE_LVAL (component) != lval_internalvar_component)
+ {
+ CORE_ADDR addr;
+ struct type *type = value_type (whole);
+
+ addr = value_raw_address (component);
+
+ if (TYPE_DATA_LOCATION (type)
+ && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+ {
+ addr = TYPE_DATA_LOCATION_ADDR (type);
+ set_value_address (component, addr);
+ }
+ }
}
@@ -3095,13 +3115,22 @@
v = allocate_value_lazy (type);
else
{
- v = allocate_value (type);
- value_contents_copy_raw (v, value_embedded_offset (v),
- arg1, value_embedded_offset (arg1) + offset,
- type_length_units (type));
+ if (TYPE_DATA_LOCATION (type)
+ && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+ v = value_at_lazy (type, value_address (arg1) + offset);
+ else
+ {
+ v = allocate_value (type);
+ value_contents_copy_raw (v, value_embedded_offset (v),
+ arg1, value_embedded_offset (arg1) + offset,
+ type_length_units (type));
+ }
}
- v->offset = (value_offset (arg1) + offset
- + value_embedded_offset (arg1));
+
+ if (!TYPE_DATA_LOCATION (type)
+ || !TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+ v->offset = (value_offset (arg1) + offset
+ + value_embedded_offset (arg1));
}
set_value_component_location (v, arg1);
VALUE_REGNUM (v) = VALUE_REGNUM (arg1);
@@ -3689,7 +3718,8 @@
struct value *original_value)
{
/* Re-adjust type. */
- deprecated_set_value_type (value, TYPE_TARGET_TYPE (original_type));
+ if (!is_dynamic_type (TYPE_TARGET_TYPE (original_type)))
+ deprecated_set_value_type (value, TYPE_TARGET_TYPE (original_type));
/* Add embedding info. */
set_value_enclosing_type (value, enc_type);
@@ -3706,6 +3736,12 @@
struct value *retval;
struct type *enc_type;
+ if (current_language->la_language != language_fortran
+ && TYPE_DATA_LOCATION (value_type_arg_tmp) != NULL
+ && TYPE_DATA_LOCATION_KIND (value_type_arg_tmp) == PROP_CONST)
+ arg = value_at_lazy (value_type_arg_tmp,
+ TYPE_DATA_LOCATION_ADDR (value_type_arg_tmp));
+
retval = coerce_ref_if_computed (arg);
if (retval)
return retval;
@@ -3834,8 +3870,14 @@
}
else if (VALUE_LVAL (val) == lval_memory)
{
- CORE_ADDR addr = value_address (val);
struct type *type = check_typedef (value_enclosing_type (val));
+ CORE_ADDR addr;
+
+ if (TYPE_DATA_LOCATION (type) != NULL
+ && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
+ addr = TYPE_DATA_LOCATION_ADDR (type);
+ else
+ addr = value_address (val);
if (TYPE_LENGTH (type))
read_value_memory (val, 0, value_stack (val),
Index: gdb-7.10.50.20160106/gdb/dwarf2loc.c
===================================================================
--- gdb-7.10.50.20160106.orig/gdb/dwarf2loc.c 2016-01-08 19:15:35.091582504 +0100
+++ gdb-7.10.50.20160106/gdb/dwarf2loc.c 2016-01-08 19:15:44.988637708 +0100
@@ -2368,6 +2368,11 @@
address = value_as_address (value_from_pointer (ptr_type, address));
do_cleanups (value_chain);
+
+ /* Select right frame to correctly evaluate VLA's during a backtrace. */
+ if (is_dynamic_type (type))
+ select_frame (frame);
+
retval = value_at_lazy (type, address + byte_offset);
if (in_stack_memory)
set_value_stack (retval, 1);
@@ -2660,6 +2665,19 @@
data, data + size, per_cu);
}
+/* See dwarf2loc.h. */
+
+int
+dwarf2_address_data_valid (const struct type *type)
+{
+ if (TYPE_NOT_ASSOCIATED (type))
+ return 0;
+
+ if (TYPE_NOT_ALLOCATED (type))
+ return 0;
+
+ return 1;
+}
/* Helper functions and baton for dwarf2_loc_desc_needs_frame. */