rpms/gdb
7
0
Fork 0
Code Issues Pull Requests Releases Activity
6d1599f359
gdb/gdb-vla-intel.patch
Jan Kratochvil 072837144c Rebase to 7.9-branch snapshot 7.8.90.20150202. 
- Temporarily disable dg-extract-results.py to fix gdb.sum sorting.
2015-02-02 23:09:42 +01:00

2958 lines
113 KiB
Diff
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

[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.8.90.20150126/gdb/c-valprint.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/c-valprint.c 2015-01-26 07:47:25.832758314 +0100
+++ gdb-7.8.90.20150126/gdb/c-valprint.c 2015-01-26 07:47:42.394829861 +0100
@@ -537,7 +537,16 @@ c_value_print (struct value *val, struct
{
/* 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.8.90.20150126/gdb/dwarf2loc.h
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/dwarf2loc.h 2015-01-26 07:47:25.832758314 +0100
+++ gdb-7.8.90.20150126/gdb/dwarf2loc.h 2015-01-26 07:47:42.395829865 +0100
@@ -111,6 +111,11 @@ int dwarf2_evaluate_property (const stru
CORE_ADDR address,
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.8.90.20150126/gdb/dwarf2read.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/dwarf2read.c 2015-01-26 07:47:25.845758371 +0100
+++ gdb-7.8.90.20150126/gdb/dwarf2read.c 2015-01-26 07:48:05.833931116 +0100
@@ -1855,6 +1855,12 @@ static void process_cu_includes (void);
static void check_producer (struct dwarf2_cu *cu);
static void free_line_header_voidp (void *arg);
+
+static int
+attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
+ struct dwarf2_cu *cu, struct dynamic_prop *prop,
+ const gdb_byte *additional_data, int additional_data_size);
+
/* Various complaints about symbol reading that don't abort the process. */
@@ -14354,29 +14360,92 @@ read_tag_string_type (struct die_info *d
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);
@@ -14693,13 +14762,15 @@ read_base_type (struct die_info *die, st
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;
@@ -14712,8 +14783,25 @@ attr_to_dynamic_prop (const struct attri
baton = obstack_alloc (obstack, sizeof (*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);
@@ -14743,8 +14831,28 @@ attr_to_dynamic_prop (const struct attri
baton = obstack_alloc (obstack, sizeof (*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);
@@ -14779,7 +14887,7 @@ read_subrange_type (struct die_info *die
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;
@@ -14799,7 +14907,9 @@ read_subrange_type (struct die_info *die
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. */
@@ -14832,19 +14942,26 @@ read_subrange_type (struct die_info *die
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)
@@ -14908,7 +15025,7 @@ read_subrange_type (struct die_info *die
&& !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;
@@ -21994,7 +22111,44 @@ set_die_type (struct die_info *die, stru
/* 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))
+ {
+ TYPE_DATA_LOCATION (type)
+ = obstack_alloc (&objfile->objfile_obstack, sizeof (prop));
+ *TYPE_DATA_LOCATION (type) = prop;
+ }
+
+ /* Read DW_AT_allocated and set in type. */
+ attr = dwarf2_attr (die, DW_AT_allocated, cu);
+ if (attr_form_is_block (attr))
+ {
+ struct dynamic_prop prop;
+
+ if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
+ {
+ TYPE_ALLOCATED_PROP (type)
+ = obstack_alloc (&objfile->objfile_obstack, sizeof (prop));
+ *TYPE_ALLOCATED_PROP (type) = prop;
+ }
+ }
+
+ /* Read DW_AT_associated and set in type. */
+ attr = dwarf2_attr (die, DW_AT_associated, cu);
+ if (attr_form_is_block (attr))
+ {
+ struct dynamic_prop prop;
+
+ if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
+ {
+ TYPE_ASSOCIATED_PROP (type)
+ = obstack_alloc (&objfile->objfile_obstack, sizeof (prop));
+ *TYPE_ASSOCIATED_PROP (type) = prop;
+ }
+ }
+
+ /* 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, NULL, 0))
{
TYPE_DATA_LOCATION (type)
= obstack_alloc (&objfile->objfile_obstack, sizeof (prop));
Index: gdb-7.8.90.20150126/gdb/f-typeprint.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/f-typeprint.c 2015-01-26 07:47:25.846758375 +0100
+++ gdb-7.8.90.20150126/gdb/f-typeprint.c 2015-01-26 07:47:42.402829895 +0100
@@ -30,6 +30,7 @@
#include "gdbcore.h"
#include "target.h"
#include "f-lang.h"
+#include "valprint.h"
#if 0 /* Currently unused. */
static void f_type_print_args (struct type *, struct ui_file *);
@@ -53,6 +54,17 @@ f_print_type (struct type *type, const c
enum type_code code;
int demangled_args;
+ 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')
@@ -167,28 +179,36 @@ f_type_print_varspec_suffix (struct type
if (arrayprint_recurse_level == 1)
fprintf_filtered (stream, "(");
- 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, "*");
+ if (TYPE_NOT_ASSOCIATED (type))
+ val_print_not_associated (stream);
+ else if (TYPE_NOT_ALLOCATED (type))
+ val_print_not_allocated (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);
+ {
+
+ 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);
+ }
if (arrayprint_recurse_level == 1)
fprintf_filtered (stream, ")");
else
Index: gdb-7.8.90.20150126/gdb/f-valprint.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/f-valprint.c 2015-01-26 07:47:25.847758379 +0100
+++ gdb-7.8.90.20150126/gdb/f-valprint.c 2015-01-26 07:47:42.403829900 +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 @@ int f77_array_offset_tbl[MAX_FORTRAN_DIM
/* 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 @@ f77_get_dynamic_length_of_aggregate (str
* 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 @@ f77_print_array_1 (int nss, int ndimensi
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 @@ f77_print_array (struct type *type, cons
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 @@ f_val_print (struct type *type, const gd
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.8.90.20150126/gdb/gdbtypes.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/gdbtypes.c 2015-01-26 07:47:25.850758392 +0100
+++ gdb-7.8.90.20150126/gdb/gdbtypes.c 2015-01-26 07:47:42.404829904 +0100
@@ -815,7 +815,8 @@ allocate_stub_method (struct type *type)
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);
@@ -830,6 +831,7 @@ create_range_type (struct type *result_t
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;
@@ -858,7 +860,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;
@@ -866,7 +868,11 @@ create_static_range_type (struct type *r
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;
}
@@ -1020,18 +1026,24 @@ create_array_type_with_stride (struct ty
TYPE_CODE (result_type) = TYPE_CODE_ARRAY;
TYPE_TARGET_TYPE (result_type) = element_type;
- if (has_static_range (TYPE_RANGE_DATA (range_type)))
+ if (has_static_range (TYPE_RANGE_DATA (range_type))
+ && dwarf2_address_data_valid (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;
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;
@@ -1630,12 +1642,31 @@ stub_noname_complaint (void)
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;
@@ -1656,11 +1687,19 @@ is_dynamic_type_internal (struct type *t
{
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:
@@ -1673,6 +1712,17 @@ is_dynamic_type_internal (struct type *t
&& 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)
+ return is_dynamic_type (check_typedef (TYPE_TARGET_TYPE (type)));
+
+ return 0;
+ break;
+ }
+ default:
+ return 0;
break;
}
@@ -1701,7 +1751,8 @@ resolve_dynamic_range (struct type *dyn_
struct type *static_range_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);
@@ -1732,10 +1783,17 @@ resolve_dynamic_range (struct type *dyn_
high_bound.kind = PROP_UNDEFINED;
high_bound.data.const_val = 0;
}
+
+ prop = &TYPE_RANGE_DATA (dyn_range_type)->stride;
+ if (dwarf2_evaluate_property (prop, addr, &value))
+ {
+ stride.kind = PROP_CONST;
+ stride.data.const_val = value;
+ }
- static_range_type = create_range_type (copy_type (dyn_range_type),
- TYPE_TARGET_TYPE (dyn_range_type),
- &low_bound, &high_bound);
+ static_range_type = create_range_type (range_copy,
+ TYPE_TARGET_TYPE (range_copy),
+ &low_bound, &high_bound, &stride);
TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1;
return static_range_type;
}
@@ -1751,23 +1809,46 @@ resolve_dynamic_array (struct type *type
struct type *elt_type;
struct type *range_type;
struct type *ary_dim;
+ struct dynamic_prop *prop;
+ struct type *copy = copy_type (type);
- gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
+ gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY
+ || TYPE_CODE (type) == TYPE_CODE_STRING);
elt_type = type;
range_type = check_typedef (TYPE_INDEX_TYPE (elt_type));
range_type = resolve_dynamic_range (range_type, addr);
+ prop = TYPE_ALLOCATED_PROP (type);
+ if (dwarf2_evaluate_property (prop, addr, &value))
+ {
+ TYPE_ALLOCATED_PROP (copy)->kind = PROP_CONST;
+ TYPE_ALLOCATED_PROP (copy)->data.const_val = value;
+ }
+
+ prop = TYPE_ASSOCIATED_PROP (type);
+ if (dwarf2_evaluate_property (prop, addr, &value))
+ {
+ TYPE_ASSOCIATED_PROP (copy)->kind = PROP_CONST;
+ TYPE_ASSOCIATED_PROP (copy)->data.const_val = value;
+ }
+
ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));
- if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)
- elt_type = resolve_dynamic_array (TYPE_TARGET_TYPE (type), addr);
+ if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY
+ || TYPE_CODE (ary_dim) == TYPE_CODE_STRING))
+ elt_type = resolve_dynamic_array (TYPE_TARGET_TYPE (copy), addr);
else
elt_type = TYPE_TARGET_TYPE (type);
- return create_array_type (copy_type (type),
- elt_type,
- range_type);
+ if (TYPE_CODE (type) == TYPE_CODE_STRING)
+ return create_string_type (copy,
+ elt_type,
+ range_type);
+ else
+ return create_array_type (copy,
+ elt_type,
+ range_type);
}
/* Resolve dynamic bounds of members of the union TYPE to static
@@ -1938,6 +2019,25 @@ resolve_dynamic_type_internal (struct ty
else
TYPE_DATA_LOCATION (resolved_type) = NULL;
+ /* Resolve data_location attribute. */
+ prop = TYPE_DATA_LOCATION (resolved_type);
+ if (dwarf2_evaluate_property (prop, addr, &value))
+ {
+ struct type *range_type = TYPE_INDEX_TYPE (resolved_type);
+
+ /* Adjust the data location with the value of byte stride if set, which
+ can describe the separation between successive elements along the
+ dimension. */
+ if (TYPE_BYTE_STRIDE (range_type) < 0)
+ value += (TYPE_HIGH_BOUND (range_type) - TYPE_LOW_BOUND (range_type))
+ * TYPE_BYTE_STRIDE (range_type);
+
+ TYPE_DATA_LOCATION_ADDR (resolved_type) = value;
+ TYPE_DATA_LOCATION_KIND (resolved_type) = PROP_CONST;
+ }
+ else
+ TYPE_DATA_LOCATION (resolved_type) = NULL;
+
return resolved_type;
}
@@ -4174,6 +4274,27 @@ copy_type_recursive (struct objfile *obj
sizeof (struct dynamic_prop));
}
+ /* Copy the data location information. */
+ if (TYPE_DATA_LOCATION (type) != NULL)
+ {
+ TYPE_DATA_LOCATION (new_type) = xmalloc (sizeof (struct dynamic_prop));
+ *TYPE_DATA_LOCATION (new_type) = *TYPE_DATA_LOCATION (type);
+ }
+
+ /* Copy allocated information. */
+ if (TYPE_ALLOCATED_PROP (type) != NULL)
+ {
+ TYPE_ALLOCATED_PROP (new_type) = xmalloc (sizeof (struct dynamic_prop));
+ *TYPE_ALLOCATED_PROP (new_type) = *TYPE_ALLOCATED_PROP (type);
+ }
+
+ /* Copy associated information. */
+ if (TYPE_ASSOCIATED_PROP (type) != NULL)
+ {
+ TYPE_ASSOCIATED_PROP (new_type) = xmalloc (sizeof (struct dynamic_prop));
+ *TYPE_ASSOCIATED_PROP (new_type) = *TYPE_ASSOCIATED_PROP (type);
+ }
+
/* Copy pointers to other types. */
if (TYPE_TARGET_TYPE (type))
TYPE_TARGET_TYPE (new_type) =
@@ -4227,6 +4348,44 @@ copy_type (const struct type *type)
sizeof (struct dynamic_prop));
}
+ if (TYPE_ALLOCATED_PROP (type))
+ {
+ TYPE_ALLOCATED_PROP (new_type)
+ = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
+ struct dynamic_prop);
+ memcpy (TYPE_ALLOCATED_PROP (new_type), TYPE_ALLOCATED_PROP (type),
+ sizeof (struct dynamic_prop));
+ }
+
+ if (TYPE_ASSOCIATED_PROP (type))
+ {
+ TYPE_ASSOCIATED_PROP (new_type)
+ = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
+ struct dynamic_prop);
+ memcpy (TYPE_ASSOCIATED_PROP (new_type), TYPE_ASSOCIATED_PROP (type),
+ sizeof (struct dynamic_prop));
+ }
+
+ if (TYPE_DATA_LOCATION (type))
+ {
+ TYPE_DATA_LOCATION (new_type)
+ = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
+ struct dynamic_prop);
+ memcpy (TYPE_DATA_LOCATION (new_type), TYPE_DATA_LOCATION (type),
+ sizeof (struct dynamic_prop));
+ }
+
+ if (TYPE_NFIELDS (type))
+ {
+ int nfields = TYPE_NFIELDS (type);
+
+ TYPE_FIELDS (new_type)
+ = OBSTACK_CALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
+ nfields, struct field);
+ memcpy (TYPE_FIELDS (new_type), TYPE_FIELDS (type),
+ nfields * sizeof (struct field));
+ }
+
return new_type;
}
Index: gdb-7.8.90.20150126/gdb/gdbtypes.h
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/gdbtypes.h 2015-01-26 07:47:25.852758401 +0100
+++ gdb-7.8.90.20150126/gdb/gdbtypes.h 2015-01-26 07:47:42.405829908 +0100
@@ -660,6 +660,10 @@ struct main_type
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. */
@@ -720,6 +724,18 @@ struct main_type
this field yields to the location of the data for an object. */
struct dynamic_prop *data_location;
+
+ /* 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
@@ -1198,6 +1214,39 @@ extern void allocate_gnat_aux_type (stru
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
+
+
+/* Attribute accessors for the type data location. */
+#define TYPE_DATA_LOCATION(thistype) \
+ TYPE_MAIN_TYPE(thistype)->data_location
+#define TYPE_DATA_LOCATION_BATON(thistype) \
+ TYPE_DATA_LOCATION (thistype)->data.baton
+#define TYPE_DATA_LOCATION_ADDR(thistype) \
+ TYPE_DATA_LOCATION (thistype)->data.const_val
+#define TYPE_DATA_LOCATION_KIND(thistype) \
+ TYPE_DATA_LOCATION (thistype)->kind
+#define TYPE_ALLOCATED_PROP(thistype) TYPE_MAIN_TYPE(thistype)->allocated
+#define TYPE_ASSOCIATED_PROP(thistype) TYPE_MAIN_TYPE(thistype)->associated
+
+/* 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)
/* Attribute accessors for the type data location. */
#define TYPE_DATA_LOCATION(thistype) \
@@ -1215,6 +1264,9 @@ extern void allocate_gnat_aux_type (stru
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))))
@@ -1685,6 +1737,7 @@ extern struct type *create_array_type_wi
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.8.90.20150126/gdb/testsuite/gdb.fortran/vla-alloc-assoc.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-alloc-assoc.exp 2015-01-26 07:47:42.405829908 +0100
@@ -0,0 +1,65 @@
+# 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 "vla.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 the association status of various types of VLA's
+# and pointer to VLA's.
+gdb_breakpoint [gdb_get_line_number "vla1-allocated"]
+gdb_continue_to_breakpoint "vla1-allocated"
+gdb_test "print l" " = \\.TRUE\\." \
+ "print vla1 allocation status (allocated)"
+
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "print l" " = \\.TRUE\\." \
+ "print vla2 allocation status (allocated)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test "print l" " = \\.TRUE\\." \
+ "print pvla associated status (associated)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
+gdb_continue_to_breakpoint "pvla-re-associated"
+gdb_test "print l" " = \\.TRUE\\." \
+ "print pvla associated status (re-associated)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
+gdb_continue_to_breakpoint "pvla-deassociated"
+gdb_test "print l" " = \\.FALSE\\." \
+ "print pvla allocation status (deassociated)"
+
+gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
+gdb_continue_to_breakpoint "vla1-deallocated"
+gdb_test "print l" " = \\.FALSE\\." \
+ "print vla1 allocation status (deallocated)"
+gdb_test "print vla1" " = <not allocated>" \
+ "print deallocated vla1"
+
+gdb_breakpoint [gdb_get_line_number "vla2-deallocated"]
+gdb_continue_to_breakpoint "vla2-deallocated"
+gdb_test "print l" " = \\.FALSE\\." "print vla2 deallocated"
+gdb_test "print vla2" " = <not allocated>" "print deallocated vla2"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-datatypes.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-datatypes.exp 2015-01-26 07:47:42.405829908 +0100
@@ -0,0 +1,82 @@
+# 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 "vlas-allocated"]
+gdb_continue_to_breakpoint "vlas-allocated"
+gdb_test "next" " = allocated\\\(realvla\\\)" \
+ "next to allocation status of intvla"
+gdb_test "print l" " = \\.TRUE\\." "intvla allocated"
+gdb_test "next" " = allocated\\\(complexvla\\\)" \
+ "next to allocation status of realvla"
+gdb_test "print l" " = \\.TRUE\\." "realvla allocated"
+gdb_test "next" " = allocated\\\(logicalvla\\\)" \
+ "next to allocation status of complexvla"
+gdb_test "print l" " = \\.TRUE\\." "complexvla allocated"
+gdb_test "next" " = allocated\\\(charactervla\\\)" \
+ "next to allocation status of logicalvla"
+gdb_test "print l" " = \\.TRUE\\." "logicalvla allocated"
+gdb_test "next" "intvla\\\(:,:,:\\\) = 1" \
+ "next to allocation status of charactervla"
+gdb_test "print l" " = \\.TRUE\\." "charactervla allocated"
+
+gdb_breakpoint [gdb_get_line_number "vlas-initialized"]
+gdb_continue_to_breakpoint "vlas-initialized"
+gdb_test "ptype intvla" "type = integer\\\(kind=4\\\) \\\(11,22,33\\\)" \
+ "ptype intvla"
+gdb_test "ptype realvla" "type = real\\\(kind=4\\\) \\\(11,22,33\\\)" \
+ "ptype realvla"
+gdb_test "ptype complexvla" "type = complex\\\(kind=4\\\) \\\(11,22,33\\\)" \
+ "ptype complexvla"
+gdb_test "ptype logicalvla" "type = logical\\\(kind=4\\\) \\\(11,22,33\\\)" \
+ "ptype logicalvla"
+gdb_test "ptype charactervla" "type = character\\\*1 \\\(11,22,33\\\)" \
+ "ptype charactervla"
+
+gdb_test "print intvla(5,5,5)" " = 1" "print intvla(5,5,5) (1st)"
+gdb_test "print realvla(5,5,5)" " = 3.14\\d+" \
+ "print realvla(5,5,5) (1st)"
+gdb_test "print complexvla(5,5,5)" " = \\\(2,-3\\\)" \
+ "print complexvla(5,5,5) (1st)"
+gdb_test "print logicalvla(5,5,5)" " = \\.TRUE\\." \
+ "print logicalvla(5,5,5) (1st)"
+gdb_test "print charactervla(5,5,5)" " = 'K'" \
+ "print charactervla(5,5,5) (1st)"
+
+gdb_breakpoint [gdb_get_line_number "vlas-modified"]
+gdb_continue_to_breakpoint "vlas-modified"
+gdb_test "print intvla(5,5,5)" " = 42" "print intvla(5,5,5) (2nd)"
+gdb_test "print realvla(5,5,5)" " = 4.13\\d+" \
+ "print realvla(5,5,5) (2nd)"
+gdb_test "print complexvla(5,5,5)" " = \\\(-3,2\\\)" \
+ "print complexvla(5,5,5) (2nd)"
+gdb_test "print logicalvla(5,5,5)" " = \\.FALSE\\." \
+ "print logicalvla(5,5,5) (2nd)"
+gdb_test "print charactervla(5,5,5)" " = 'X'" \
+ "print charactervla(5,5,5) (2nd)"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-datatypes.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-datatypes.f90 2015-01-26 07:47:42.405829908 +0100
@@ -0,0 +1,51 @@
+! 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_primitives
+ integer, allocatable :: intvla(:, :, :)
+ real, allocatable :: realvla(:, :, :)
+ complex, allocatable :: complexvla(:, :, :)
+ logical, allocatable :: logicalvla(:, :, :)
+ character, allocatable :: charactervla(:, :, :)
+ logical :: l
+
+ allocate (intvla (11,22,33))
+ allocate (realvla (11,22,33))
+ allocate (complexvla (11,22,33))
+ allocate (logicalvla (11,22,33))
+ allocate (charactervla (11,22,33))
+
+ l = allocated(intvla) ! vlas-allocated
+ l = allocated(realvla)
+ l = allocated(complexvla)
+ l = allocated(logicalvla)
+ l = allocated(charactervla)
+
+ intvla(:,:,:) = 1
+ realvla(:,:,:) = 3.14
+ complexvla(:,:,:) = cmplx(2.0,-3.0)
+ logicalvla(:,:,:) = .TRUE.
+ charactervla(:,:,:) = char(75)
+
+ intvla(5,5,5) = 42 ! vlas-initialized
+ realvla(5,5,5) = 4.13
+ complexvla(5,5,5) = cmplx(-3.0,2.0)
+ logicalvla(5,5,5) = .FALSE.
+ charactervla(5,5,5) = 'X'
+
+ ! dummy statement for bp
+ l = .FALSE. ! vlas-modified
+end program vla_primitives
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-func.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-func.exp 2015-01-26 07:47:42.406829913 +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.8.90.20150126/gdb/testsuite/gdb.fortran/vla-func.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-func.f90 2015-01-26 07:47:42.406829913 +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.8.90.20150126/gdb/testsuite/gdb.fortran/vla-history.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-history.exp 2015-01-26 07:47:42.406829913 +0100
@@ -0,0 +1,62 @@
+# 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 "vla.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
+}
+
+# Set some breakpoints and print complete vla.
+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_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "print vla1" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
+ "print vla1 allocated"
+gdb_test "print vla2" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
+ "print vla2 allocated"
+
+gdb_breakpoint [gdb_get_line_number "vla1-filled"]
+gdb_continue_to_breakpoint "vla1-filled"
+gdb_test "print vla1" \
+ " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" \
+ "print vla1 filled"
+
+# Try to access history values for full vla prints.
+gdb_test "print \$1" " = <not allocated>" "print \$1"
+gdb_test "print \$2" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
+ "print \$2"
+gdb_test "print \$3" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
+ "print \$3"
+gdb_test "print \$4" \
+ " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" "print \$4"
+
+gdb_breakpoint [gdb_get_line_number "vla2-filled"]
+gdb_continue_to_breakpoint "vla2-filled"
+gdb_test "print vla2(1,43,20)" " = 1311" "print vla2(1,43,20)"
+gdb_test "print vla1(1,3,8)" " = 1001" "print vla2(1,3,8)"
+
+# Try to access history values for vla values.
+gdb_test "print \$9" " = 1311" "print \$9"
+gdb_test "print \$10" " = 1001" "print \$10"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-ptype-sub.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-ptype-sub.exp 2015-01-26 07:47:42.406829913 +0100
@@ -0,0 +1,87 @@
+# 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 "vla-sub.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
+}
+
+# Pass fixed array to function and handle them as vla in function.
+gdb_breakpoint [gdb_get_line_number "not-filled"]
+gdb_continue_to_breakpoint "not-filled (1st)"
+gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(42,42\\\)" \
+ "ptype array1 (passed fixed)"
+gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(42,42,42\\\)" \
+ "ptype array2 (passed fixed)"
+gdb_test "ptype array1(40, 10)" "type = integer\\\(kind=4\\\)" \
+ "ptype array1(40, 10) (passed fixed)"
+gdb_test "ptype array2(13, 11, 5)" "type = real\\\(kind=4\\\)" \
+ "ptype array2(13, 11, 5) (passed fixed)"
+
+# Pass sub arrays to function and handle them as vla in function.
+gdb_continue_to_breakpoint "not-filled (2nd)"
+gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(6,6\\\)" \
+ "ptype array1 (passed sub-array)"
+gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(6,6,6\\\)" \
+ "ptype array2 (passed sub-array)"
+gdb_test "ptype array1(3, 3)" "type = integer\\\(kind=4\\\)" \
+ "ptype array1(3, 3) (passed sub-array)"
+gdb_test "ptype array2(4, 4, 4)" "type = real\\\(kind=4\\\)" \
+ "ptype array2(4, 4, 4) (passed sub-array)"
+
+# Check ptype outside of bounds. This should not crash GDB.
+gdb_test "ptype array1(100, 100)" "no such vector element" \
+ "ptype array1(100, 100) subarray do not crash (passed sub-array)"
+gdb_test "ptype array2(100, 100, 100)" "no such vector element" \
+ "ptype array2(100, 100, 100) subarray do not crash (passed sub-array)"
+
+# Pass vla to function.
+gdb_continue_to_breakpoint "not-filled (3rd)"
+gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(20,20\\\)" \
+ "ptype array1 (passed vla)"
+gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
+ "ptype array2 (passed vla)"
+gdb_test "ptype array1(3, 3)" "type = integer\\\(kind=4\\\)" \
+ "ptype array1(3, 3) (passed vla)"
+gdb_test "ptype array2(4, 4, 4)" "type = real\\\(kind=4\\\)" \
+ "ptype array2(4, 4, 4) (passed vla)"
+
+# Check ptype outside of bounds. This should not crash GDB.
+gdb_test "ptype array1(100, 100)" "no such vector element" \
+ "ptype array1(100, 100) VLA do not crash (passed vla)"
+gdb_test "ptype array2(100, 100, 100)" "no such vector element" \
+ "ptype array2(100, 100, 100) VLA do not crash (passed vla)"
+
+# Pass fixed array to function and handle it as VLA of arbitrary length in
+# function.
+gdb_breakpoint [gdb_get_line_number "end-of-bar"]
+gdb_continue_to_breakpoint "end-of-bar"
+gdb_test "ptype array1" \
+ "type = (PTR TO -> \\( )?integer(\\(kind=4\\)|\\*4) \\(\\*\\)\\)?" \
+ "ptype array1 (arbitrary length)"
+gdb_test "ptype array2" \
+ "type = (PTR TO -> \\( )?integer(\\(kind=4\\)|\\*4) \\(4:9,10:\\*\\)\\)?" \
+ "ptype array2 (arbitrary length)"
+gdb_test "ptype array1(100)" "type = integer\\\(kind=4\\\)" \
+ "ptype array1(100) (arbitrary length)"
+gdb_test "ptype array2(4,100)" "type = integer\\\(kind=4\\\)" \
+ "ptype array2(4,100) (arbitrary length)"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-ptype.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-ptype.exp 2015-01-26 07:47:42.406829913 +0100
@@ -0,0 +1,96 @@
+# 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 "vla.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 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(3, 6, 9)" "no such vector element because not allocated" \
+ "ptype vla1(3, 6, 9) not initialized"
+gdb_test "ptype vla2(5, 45, 20)" \
+ "no such vector element because not allocated" \
+ "ptype vla1(5, 45, 20) not initialized"
+
+gdb_breakpoint [gdb_get_line_number "vla1-allocated"]
+gdb_continue_to_breakpoint "vla1-allocated"
+gdb_test "ptype vla1" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
+ "ptype vla1 allocated"
+
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "ptype vla2" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
+ "ptype vla2 allocated"
+
+gdb_breakpoint [gdb_get_line_number "vla1-filled"]
+gdb_continue_to_breakpoint "vla1-filled"
+gdb_test "ptype vla1" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
+ "ptype vla1 filled"
+gdb_test "ptype vla1(3, 6, 9)" "type = real\\\(kind=4\\\)" \
+ "ptype vla1(3, 6, 9)"
+
+gdb_breakpoint [gdb_get_line_number "vla2-filled"]
+gdb_continue_to_breakpoint "vla2-filled"
+gdb_test "ptype vla2" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
+ "ptype vla2 filled"
+gdb_test "ptype vla2(5, 45, 20)" "type = real\\\(kind=4\\\)" \
+ "ptype vla1(5, 45, 20) filled"
+
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test "ptype pvla" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
+ "ptype pvla associated"
+gdb_test "ptype pvla(3, 6, 9)" "type = real\\\(kind=4\\\)" \
+ "ptype pvla(3, 6, 9)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
+gdb_continue_to_breakpoint "pvla-re-associated"
+gdb_test "ptype pvla" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
+ "ptype pvla re-associated"
+gdb_test "ptype vla2(5, 45, 20)" "type = real\\\(kind=4\\\)" \
+ "ptype vla1(5, 45, 20) re-associated"
+
+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(5, 45, 20)" \
+ "no such vector element because 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(3, 6, 9)" "no such vector element because 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(5, 45, 20)" \
+ "no such vector element because not allocated" \
+ "ptype vla2(5, 45, 20) not allocated"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-sizeof.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-sizeof.exp 2015-01-26 07:47:42.406829913 +0100
@@ -0,0 +1,46 @@
+# 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 "vla.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
+}
+
+# Try to access values in non allocated VLA
+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"
+
+# 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"
+
+# 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"
+
+# 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"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-stride.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-stride.exp 2015-01-26 07:47:42.407829917 +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.8.90.20150126/gdb/testsuite/gdb.fortran/vla-stride.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-stride.f90 2015-01-26 07:47:42.407829917 +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.8.90.20150126/gdb/testsuite/gdb.fortran/vla-strings.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-strings.exp 2015-01-26 07:47:42.407829917 +0100
@@ -0,0 +1,104 @@
+# 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 "print *var_char" \
+ " = '\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000'" \
+ "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.8.90.20150126/gdb/testsuite/gdb.fortran/vla-strings.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-strings.f90 2015-01-26 07:47:42.407829917 +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.8.90.20150126/gdb/testsuite/gdb.fortran/vla-sub.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-sub.f90 2015-01-26 07:47:42.407829917 +0100
@@ -0,0 +1,82 @@
+! 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.
+!
+! Original file written by Jakub Jelinek <jakub@redhat.com> and
+! Jan Kratochvil <jan.kratochvil@redhat.com>.
+! Modified for the GDB testcases by Keven Boell <keven.boell@intel.com>.
+
+subroutine foo (array1, array2)
+ integer :: array1 (:, :)
+ real :: array2 (:, :, :)
+
+ array1(:,:) = 5 ! not-filled
+ array1(1, 1) = 30
+
+ array2(:,:,:) = 6 ! array1-filled
+ array2(:,:,:) = 3
+ array2(1,1,1) = 30
+ array2(3,3,3) = 90 ! array2-almost-filled
+end subroutine
+
+subroutine bar (array1, array2)
+ integer :: array1 (*)
+ integer :: array2 (4:9, 10:*)
+
+ array1(5:10) = 1311
+ array1(7) = 1
+ array1(100) = 100
+ array2(4,10) = array1(7)
+ array2(4,100) = array1(7)
+ return ! end-of-bar
+end subroutine
+
+program vla_sub
+ interface
+ subroutine foo (array1, array2)
+ integer :: array1 (:, :)
+ real :: array2 (:, :, :)
+ end subroutine
+ end interface
+ interface
+ subroutine bar (array1, array2)
+ integer :: array1 (*)
+ integer :: array2 (4:9, 10:*)
+ end subroutine
+ end interface
+
+ real, allocatable :: vla1 (:, :, :)
+ integer, allocatable :: vla2 (:, :)
+
+ ! used for subroutine
+ integer :: sub_arr1(42, 42)
+ real :: sub_arr2(42, 42, 42)
+ integer :: sub_arr3(42)
+
+ sub_arr1(:,:) = 1 ! vla2-deallocated
+ sub_arr2(:,:,:) = 2
+ sub_arr3(:) = 3
+
+ call foo(sub_arr1, sub_arr2)
+ call foo(sub_arr1(5:10, 5:10), sub_arr2(10:15,10:15,10:15))
+
+ allocate (vla1 (10,10,10))
+ allocate (vla2 (20,20))
+ vla1(:,:,:) = 1311
+ vla2(:,:) = 42
+ call foo(vla2, vla1)
+
+ call bar(sub_arr3, sub_arr1)
+end program vla_sub
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-value-sub-arbitrary.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-value-sub-arbitrary.exp 2015-01-26 07:47:42.407829917 +0100
@@ -0,0 +1,35 @@
+# 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 "vla-sub.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 with arbitary length and check that elements outside of
+# bounds of the passed VLA can be accessed correctly.
+gdb_breakpoint [gdb_get_line_number "end-of-bar"]
+gdb_continue_to_breakpoint "end-of-bar"
+gdb_test "p array1(42)" " = 3" "print arbitary array1(42)"
+gdb_test "p array1(100)" " = 100" "print arbitary array1(100)"
+gdb_test "p array2(4,10)" " = 1" "print arbitary array2(4,10)"
+gdb_test "p array2(4,100)" " = 1" "print arbitary array2(4,100)"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-value-sub-finish.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-value-sub-finish.exp 2015-01-26 07:47:42.407829917 +0100
@@ -0,0 +1,49 @@
+# 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 "vla-sub.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
+}
+
+# "up" works with GCC but other Fortran compilers may copy the values into the
+# outer function only on the exit of the inner function.
+# We need both variants as depending on the arch we optionally may still be
+# executing the caller line or not after `finish'.
+
+gdb_breakpoint [gdb_get_line_number "array2-almost-filled"]
+gdb_continue_to_breakpoint "array2-almost-filled"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was filled"
+gdb_test "print array2(2,1,1)=20" " = 20" \
+ "set array(2,2,2) to 20 in subroutine"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was mofified in debugger"
+
+gdb_test "finish" \
+ ".*foo\\\(sub_arr1\\\(5:10, 5:10\\\), sub_arr2\\\(10:15,10:15,10:15\\\)\\\)" \
+ "finish function"
+gdb_test "p sub_arr1(5, 7)" " = 5" "sub_arr1(5, 7) after finish"
+gdb_test "p sub_arr1(1, 1)" " = 30" "sub_arr1(1, 1) after finish"
+gdb_test "p sub_arr2(1, 1, 1)" " = 30" "sub_arr2(1, 1, 1) after finish"
+gdb_test "p sub_arr2(2, 1, 1)" " = 20" "sub_arr2(2, 1, 1) after finish"
+
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-value-sub.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-value-sub.exp 2015-01-26 07:47:42.408829922 +0100
@@ -0,0 +1,90 @@
+# 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 "vla-sub.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 the values of VLA's in subroutine can be evaluated correctly
+
+# Try to access values from a fixed array handled as VLA in subroutine.
+gdb_breakpoint [gdb_get_line_number "not-filled"]
+gdb_continue_to_breakpoint "not-filled (1st)"
+gdb_test "print array1" " = \\(\[()1, .\]*\\)" \
+ "print passed array1 in foo (passed fixed array)"
+
+gdb_breakpoint [gdb_get_line_number "array1-filled"]
+gdb_continue_to_breakpoint "array1-filled (1st)"
+gdb_test "print array1(5, 7)" " = 5" \
+ "print array1(5, 7) after filled in foo (passed fixed array)"
+gdb_test "print array1(1, 1)" " = 30" \
+ "print array1(1, 1) after filled in foo (passed fixed array)"
+
+gdb_breakpoint [gdb_get_line_number "array2-almost-filled"]
+gdb_continue_to_breakpoint "array2-almost-filled (1st)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was filled (passed fixed array)"
+gdb_test "print array2(2,1,1)=20" " = 20" \
+ "set array(2,2,2) to 20 in subroutine (passed fixed array)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was mofified in debugger (passed fixed array)"
+
+
+# Try to access values from a fixed sub-array handled as VLA in subroutine.
+gdb_continue_to_breakpoint "not-filled (2nd)"
+gdb_test "print array1" " = \\(\[()5, .\]*\\)" \
+ "print passed array1 in foo (passed sub-array)"
+
+gdb_continue_to_breakpoint "array1-filled (2nd)"
+gdb_test "print array1(5, 5)" " = 5" \
+ "print array1(5, 5) after filled in foo (passed sub-array)"
+gdb_test "print array1(1, 1)" " = 30" \
+ "print array1(1, 1) after filled in foo (passed sub-array)"
+
+gdb_continue_to_breakpoint "array2-almost-filled (2nd)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was filled (passed sub-array)"
+gdb_test "print array2(2,1,1)=20" " = 20" \
+ "set array(2,2,2) to 20 in subroutine (passed sub-array)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was mofified in debugger (passed sub-array)"
+
+
+# Try to access values from a VLA passed to subroutine.
+gdb_continue_to_breakpoint "not-filled (3rd)"
+gdb_test "print array1" " = \\(\[()42, .\]*\\)" \
+ "print passed array1 in foo (passed vla)"
+
+gdb_continue_to_breakpoint "array1-filled (3rd)"
+gdb_test "print array1(5, 5)" " = 5" \
+ "print array1(5, 5) after filled in foo (passed vla)"
+gdb_test "print array1(1, 1)" " = 30" \
+ "print array1(1, 1) after filled in foo (passed vla)"
+
+gdb_continue_to_breakpoint "array2-almost-filled (3rd)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was filled (passed vla)"
+gdb_test "print array2(2,1,1)=20" " = 20" \
+ "set array(2,2,2) to 20 in subroutine (passed vla)"
+gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
+ "print array2 in foo after it was mofified in debugger (passed vla)"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-value.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla-value.exp 2015-01-26 07:47:42.408829922 +0100
@@ -0,0 +1,148 @@
+# 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 "vla.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
+}
+
+# Try to access values in non allocated VLA
+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\\\(kind=4\\\) \\\(<not allocated>\\\)\\\)\\\) $hex" \
+ "print non-allocated &vla1"
+gdb_test "print vla1(1,1,1)" "no such vector element because not allocated" \
+ "print member in non-allocated vla1 (1)"
+gdb_test "print vla1(101,202,303)" \
+ "no such vector element because not allocated" \
+ "print member in non-allocated vla1 (2)"
+gdb_test "print vla1(5,2,18)=1" "no such vector element because not allocated" \
+ "set member in non-allocated vla1"
+
+# Try to access value in allocated VLA
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "next" "\\d+(\\t|\\s)+vla1\\\(3, 6, 9\\\) = 42" \
+ "step over value assignment of vla1"
+gdb_test "print &vla1" \
+ " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(10,10,10\\\)\\\)\\\) $hex" \
+ "print allocated &vla1"
+gdb_test "print vla1(3, 6, 9)" " = 1311" "print allocated vla1(3,6,9)"
+gdb_test "print vla1(1, 3, 8)" " = 1311" "print allocated vla1(1,3,8)"
+gdb_test "print vla1(9, 9, 9) = 999" " = 999" \
+ "print allocated vla1(9,9,9)=1"
+
+# Try to access values in allocated VLA after specific assignment
+gdb_breakpoint [gdb_get_line_number "vla1-filled"]
+gdb_continue_to_breakpoint "vla1-filled"
+gdb_test "print vla1(3, 6, 9)" " = 42" \
+ "print allocated vla1(3,6,9) after specific assignment (filled)"
+gdb_test "print vla1(1, 3, 8)" " = 1001" \
+ "print allocated vla1(1,3,8) after specific assignment (filled)"
+gdb_test "print vla1(9, 9, 9)" " = 999" \
+ "print allocated vla1(9,9,9) after assignment in debugger (filled)"
+
+# 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\\\(kind=4\\\) \\\(<not associated>\\\)\\\)\\\) $hex" \
+ "print non-associated &pvla"
+gdb_test "print pvla(1, 3, 8)" "no such vector element because not associated" \
+ "print undefined pvla(1,3,8)"
+
+# 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 &pvla" \
+ " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(10,10,10\\\)\\\)\\\) $hex" \
+ "print associated &pvla"
+gdb_test "print pvla(3, 6, 9)" " = 42" "print associated pvla(3,6,9)"
+gdb_test "print pvla(1, 3, 8)" " = 1001" "print associated pvla(1,3,8)"
+gdb_test "print pvla(9, 9, 9)" " = 999" "print associated pvla(9,9,9)"
+
+# Fill values to VLA using pointer and check
+gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
+gdb_continue_to_breakpoint "pvla-re-associated"
+gdb_test "print pvla(5, 45, 20)" \
+ " = 1" "print pvla(5, 45, 20) after filled using pointer"
+gdb_test "print vla2(5, 45, 20)" \
+ " = 1" "print vla2(5, 45, 20) after filled using pointer"
+gdb_test "print pvla(7, 45, 14)" " = 2" \
+ "print pvla(7, 45, 14) after filled using pointer"
+gdb_test "print vla2(7, 45, 14)" " = 2" \
+ "print vla2(7, 45, 14) after filled using pointer"
+
+# Try to access values of deassociated VLA pointer
+gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
+gdb_continue_to_breakpoint "pvla-deassociated"
+gdb_test "print pvla(5, 45, 20)" \
+ "no such vector element because not associated" \
+ "print pvla(5, 45, 20) after deassociated"
+gdb_test "print pvla(7, 45, 14)" \
+ "no such vector element because not associated" \
+ "print pvla(7, 45, 14) after dissasociated"
+gdb_test "print pvla" " = <not associated>" \
+ "print vla1 after deassociated"
+
+# Try to access values of deallocated VLA
+gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
+gdb_continue_to_breakpoint "vla1-deallocated"
+gdb_test "print vla1(3, 6, 9)" "no such vector element because not allocated" \
+ "print allocated vla1(3,6,9) after specific assignment (deallocated)"
+gdb_test "print vla1(1, 3, 8)" "no such vector element because not allocated" \
+ "print allocated vla1(1,3,8) after specific assignment (deallocated)"
+gdb_test "print vla1(9, 9, 9)" "no such vector element because not allocated" \
+ "print allocated vla1(9,9,9) after assignment in debugger (deallocated)"
+
+
+# Try to assign VLA to user variable
+clean_restart ${testfile}
+
+if ![runto MAIN__] then {
+ perror "couldn't run to breakpoint MAIN__"
+ continue
+}
+gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
+gdb_continue_to_breakpoint "vla2-allocated"
+gdb_test "next" "\\d+.*vla1\\(3, 6, 9\\) = 42" "next (1)"
+
+gdb_test_no_output "set \$myvar = vla1" "set \$myvar = vla1"
+gdb_test "print \$myvar" \
+ " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" \
+ "print \$myvar set to vla1"
+
+gdb_test "next" "\\d+.*vla1\\(1, 3, 8\\) = 1001" "next (2)"
+gdb_test "print \$myvar(3,6,9)" " = 1311" "print \$myvar(3,6,9)"
+
+gdb_breakpoint [gdb_get_line_number "pvla-associated"]
+gdb_continue_to_breakpoint "pvla-associated"
+gdb_test_no_output "set \$mypvar = pvla" "set \$mypvar = pvla"
+gdb_test "print \$mypvar(1,3,8)" " = 1001" "print \$mypvar(1,3,8)"
+
+# deallocate pointer and make sure user defined variable still has the
+# right value.
+gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
+gdb_continue_to_breakpoint "pvla-deassociated"
+gdb_test "print \$mypvar(1,3,8)" " = 1001" \
+ "print \$mypvar(1,3,8) after deallocated"
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.fortran/vla.f90 2015-01-26 07:47:42.408829922 +0100
@@ -0,0 +1,56 @@
+! 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/>.
+
+program vla
+ real, target, allocatable :: vla1 (:, :, :)
+ real, target, allocatable :: vla2 (:, :, :)
+ real, target, allocatable :: vla3 (:, :)
+ real, pointer :: pvla (:, :, :)
+ logical :: l
+
+ allocate (vla1 (10,10,10)) ! vla1-init
+ l = allocated(vla1)
+
+ allocate (vla2 (1:7,42:50,13:35)) ! vla1-allocated
+ l = allocated(vla2)
+
+ vla1(:, :, :) = 1311 ! vla2-allocated
+ vla1(3, 6, 9) = 42
+ vla1(1, 3, 8) = 1001
+ vla1(6, 2, 7) = 13
+
+ vla2(:, :, :) = 1311 ! vla1-filled
+ vla2(5, 45, 20) = 42
+
+ pvla => vla1 ! vla2-filled
+ l = associated(pvla)
+
+ pvla => vla2 ! pvla-associated
+ l = associated(pvla)
+ pvla(5, 45, 20) = 1
+ pvla(7, 45, 14) = 2
+
+ pvla => null() ! pvla-re-associated
+ l = associated(pvla)
+
+ deallocate (vla1) ! pvla-deassociated
+ l = allocated(vla1)
+
+ deallocate (vla2) ! vla1-deallocated
+ l = allocated(vla2)
+
+ allocate (vla3 (2,2)) ! vla2-deallocated
+ vla3(:,:) = 13
+end program vla
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.mi/mi-vla-fortran.exp 2015-01-26 07:47:42.408829922 +0100
@@ -0,0 +1,182 @@
+# 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/>.
+
+# Verify that, using the MI, we can evaluate a simple C Variable Length
+# Array (VLA).
+
+load_lib mi-support.exp
+set MIFLAGS "-i=mi"
+
+gdb_exit
+if [mi_gdb_start] {
+ continue
+}
+
+standard_testfile vla.f90
+
+if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable \
+ {debug f90}] != "" } {
+ untested mi-vla-fortran.exp
+ return -1
+}
+
+mi_delete_breakpoints
+mi_gdb_reinitialize_dir $srcdir/$subdir
+mi_gdb_load ${binfile}
+
+set bp_lineno [gdb_get_line_number "vla1-not-allocated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 1 "del" "vla" \
+ ".*vla.f90" $bp_lineno $hex \
+ "insert breakpoint at line $bp_lineno (vla not allocated)"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "500-data-evaluate-expression vla1" \
+ "500\\^done,value=\"<not allocated>\"" "evaluate not allocated vla"
+
+mi_create_varobj_checked vla1_not_allocated vla1 "<not allocated>" \
+ "create local variable vla1_not_allocated"
+mi_gdb_test "501-var-info-type vla1_not_allocated" \
+ "501\\^done,type=\"<not allocated>\"" \
+ "info type variable vla1_not_allocated"
+mi_gdb_test "502-var-show-format vla1_not_allocated" \
+ "502\\^done,format=\"natural\"" \
+ "show format variable vla1_not_allocated"
+mi_gdb_test "503-var-evaluate-expression vla1_not_allocated" \
+ "503\\^done,value=\"\\\[0\\\]\"" \
+ "eval variable vla1_not_allocated"
+mi_list_array_varobj_children_with_index "vla1_not_allocated" "0" "1" \
+ "real\\\(kind=4\\\)" "get children of vla1_not_allocated"
+
+
+
+set bp_lineno [gdb_get_line_number "vla1-allocated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 2 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno (vla allocated)"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "510-data-evaluate-expression vla1" \
+ "510\\^done,value=\"\\(0, 0, 0, 0, 0\\)\"" "evaluate allocated vla"
+
+mi_create_varobj_checked vla1_allocated vla1 "real\\\(kind=4\\\) \\\(5\\\)" \
+ "create local variable vla1_allocated"
+mi_gdb_test "511-var-info-type vla1_allocated" \
+ "511\\^done,type=\"real\\\(kind=4\\\) \\\(5\\\)\"" \
+ "info type variable vla1_allocated"
+mi_gdb_test "512-var-show-format vla1_allocated" \
+ "512\\^done,format=\"natural\"" \
+ "show format variable vla1_allocated"
+mi_gdb_test "513-var-evaluate-expression vla1_allocated" \
+ "513\\^done,value=\"\\\[5\\\]\"" \
+ "eval variable vla1_allocated"
+mi_list_array_varobj_children_with_index "vla1_allocated" "5" "1" \
+ "real\\\(kind=4\\\)" "get children of vla1_allocated"
+
+
+set bp_lineno [gdb_get_line_number "vla1-filled"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 3 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "520-data-evaluate-expression vla1" \
+ "520\\^done,value=\"\\(1, 1, 1, 1, 1\\)\"" "evaluate filled vla"
+
+
+set bp_lineno [gdb_get_line_number "vla1-modified"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 4 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "530-data-evaluate-expression vla1" \
+ "530\\^done,value=\"\\(1, 42, 1, 24, 1\\)\"" "evaluate filled vla"
+mi_gdb_test "540-data-evaluate-expression vla1(1)" \
+ "540\\^done,value=\"1\"" "evaluate filled vla"
+mi_gdb_test "550-data-evaluate-expression vla1(2)" \
+ "550\\^done,value=\"42\"" "evaluate filled vla"
+mi_gdb_test "560-data-evaluate-expression vla1(4)" \
+ "560\\^done,value=\"24\"" "evaluate filled vla"
+
+
+set bp_lineno [gdb_get_line_number "vla1-deallocated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 5 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "570-data-evaluate-expression vla1" \
+ "570\\^done,value=\"<not allocated>\"" "evaluate not allocated vla"
+
+
+set bp_lineno [gdb_get_line_number "pvla2-not-associated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 6 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "580-data-evaluate-expression pvla2" \
+ "580\\^done,value=\"<not associated>\"" "evaluate not associated vla"
+
+mi_create_varobj_checked pvla2_not_associated pvla2 "<not associated>" \
+ "create local variable pvla2_not_associated"
+mi_gdb_test "581-var-info-type pvla2_not_associated" \
+ "581\\^done,type=\"<not associated>\"" \
+ "info type variable pvla2_not_associated"
+mi_gdb_test "582-var-show-format pvla2_not_associated" \
+ "582\\^done,format=\"natural\"" \
+ "show format variable pvla2_not_associated"
+mi_gdb_test "583-var-evaluate-expression pvla2_not_associated" \
+ "583\\^done,value=\"\\\[0\\\]\"" \
+ "eval variable pvla2_not_associated"
+mi_list_array_varobj_children_with_index "pvla2_not_associated" "0" "1" \
+ "real\\\(kind=4\\\)" "get children of pvla2_not_associated"
+
+
+set bp_lineno [gdb_get_line_number "pvla2-associated"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 7 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "590-data-evaluate-expression pvla2" \
+ "590\\^done,value=\"\\(\\( 2, 2, 2, 2, 2\\) \\( 2, 2, 2, 2, 2\\) \\)\"" \
+ "evaluate associated vla"
+
+mi_create_varobj_checked pvla2_associated pvla2 \
+ "real\\\(kind=4\\\) \\\(5,2\\\)" "create local variable pvla2_associated"
+mi_gdb_test "591-var-info-type pvla2_associated" \
+ "591\\^done,type=\"real\\\(kind=4\\\) \\\(5,2\\\)\"" \
+ "info type variable pvla2_associated"
+mi_gdb_test "592-var-show-format pvla2_associated" \
+ "592\\^done,format=\"natural\"" \
+ "show format variable pvla2_associated"
+mi_gdb_test "593-var-evaluate-expression pvla2_associated" \
+ "593\\^done,value=\"\\\[2\\\]\"" \
+ "eval variable pvla2_associated"
+
+
+set bp_lineno [gdb_get_line_number "pvla2-set-to-null"]
+mi_create_breakpoint "-t vla.f90:$bp_lineno" 8 "del" "vla" ".*vla.f90" \
+ $bp_lineno $hex "insert breakpoint at line $bp_lineno"
+mi_run_cmd
+mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
+ { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
+mi_gdb_test "600-data-evaluate-expression pvla2" \
+ "600\\^done,value=\"<not associated>\"" "evaluate vla pointer set to null"
+
+mi_gdb_exit
+return 0
Index: gdb-7.8.90.20150126/gdb/testsuite/gdb.mi/vla.f90
===================================================================
--- /dev/null 1970-01-01 00:00:00.000000000 +0000
+++ gdb-7.8.90.20150126/gdb/testsuite/gdb.mi/vla.f90 2015-01-26 07:47:42.409829926 +0100
@@ -0,0 +1,42 @@
+! 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/>.
+
+program vla
+ real, allocatable :: vla1 (:)
+ real, target, allocatable :: vla2(:, :)
+ real, pointer :: pvla2 (:, :)
+ logical :: l
+
+ allocate (vla1 (5)) ! vla1-not-allocated
+ l = allocated(vla1) ! vla1-allocated
+
+ vla1(:) = 1
+ vla1(2) = 42 ! vla1-filled
+ vla1(4) = 24
+
+ deallocate (vla1) ! vla1-modified
+ l = allocated(vla1) ! vla1-deallocated
+
+ allocate (vla2 (5, 2))
+ vla2(:, :) = 2
+
+ pvla2 => vla2 ! pvla2-not-associated
+ l = associated(pvla2) ! pvla2-associated
+
+ pvla2(2, 1) = 42
+
+ pvla2 => null()
+ l = associated(pvla2) ! pvla2-set-to-null
+end program vla
Index: gdb-7.8.90.20150126/gdb/typeprint.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/typeprint.c 2015-01-26 07:47:25.856758418 +0100
+++ gdb-7.8.90.20150126/gdb/typeprint.c 2015-01-26 07:47:42.409829926 +0100
@@ -456,6 +456,13 @@ whatis_exp (char *exp, int show)
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.8.90.20150126/gdb/valarith.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/valarith.c 2015-01-26 07:47:25.857758422 +0100
+++ gdb-7.8.90.20150126/gdb/valarith.c 2015-01-26 07:47:42.409829926 +0100
@@ -193,12 +193,31 @@ value_subscripted_rvalue (struct value *
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 (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 (array_type)))
- error (_("no such vector element"));
+ {
+ if (TYPE_NOT_ASSOCIATED (array_type))
+ error (_("no such vector element because not associated"));
+ else if (TYPE_NOT_ALLOCATED (array_type))
+ error (_("no such vector element because not allocated"));
+ else
+ error (_("no such vector element"));
+ }
if (VALUE_LVAL (array) == lval_memory && value_lazy (array))
v = allocate_value_lazy (elt_type);
Index: gdb-7.8.90.20150126/gdb/valprint.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/valprint.c 2015-01-26 07:47:25.858758427 +0100
+++ gdb-7.8.90.20150126/gdb/valprint.c 2015-01-26 07:47:42.410829930 +0100
@@ -303,6 +303,18 @@ valprint_check_validity (struct ui_file
{
CHECK_TYPEDEF (type);
+ 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)
@@ -359,6 +371,18 @@ val_print_invalid_address (struct ui_fil
fprintf_filtered (stream, _("<invalid address>"));
}
+void
+val_print_not_allocated (struct ui_file *stream)
+{
+ fprintf_filtered (stream, _("<not allocated>"));
+}
+
+void
+val_print_not_associated (struct ui_file *stream)
+{
+ fprintf_filtered (stream, _("<not associated>"));
+}
+
/* A generic val_print that is suitable for use by language
implementations of the la_val_print method. This function can
handle most type codes, though not all, notably exception
@@ -800,12 +824,16 @@ static int
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)))
@@ -831,6 +859,18 @@ value_check_printable (struct value *val
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.8.90.20150126/gdb/valprint.h
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/valprint.h 2015-01-26 07:47:25.859758431 +0100
+++ gdb-7.8.90.20150126/gdb/valprint.h 2015-01-26 07:47:42.410829930 +0100
@@ -217,4 +217,8 @@ extern void output_command_const (const
extern int val_print_scalar_type_p (struct type *type);
+extern void val_print_not_allocated (struct ui_file *stream);
+
+extern void val_print_not_associated (struct ui_file *stream);
+
#endif
Index: gdb-7.8.90.20150126/gdb/value.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/value.c 2015-01-26 07:47:25.860758435 +0100
+++ gdb-7.8.90.20150126/gdb/value.c 2015-01-26 07:47:42.411829935 +0100
@@ -40,6 +40,7 @@
#include "tracepoint.h"
#include "cp-abi.h"
#include "user-regs.h"
+#include "dwarf2loc.h"
/* Prototypes for exported functions. */
@@ -1755,6 +1756,25 @@ set_value_component_location (struct val
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);
+ }
+ }
}
@@ -3041,13 +3061,22 @@ value_primitive_field (struct value *arg
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 (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 (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);
@@ -3635,7 +3664,8 @@ readjust_indirect_value_type (struct val
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);
@@ -3652,6 +3682,12 @@ coerce_ref (struct value *arg)
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;
@@ -3786,8 +3822,14 @@ value_fetch_lazy (struct value *val)
}
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.8.90.20150126/gdb/dwarf2loc.c
===================================================================
--- gdb-7.8.90.20150126.orig/gdb/dwarf2loc.c 2015-01-26 07:47:25.862758444 +0100
+++ gdb-7.8.90.20150126/gdb/dwarf2loc.c 2015-01-26 07:47:42.412829939 +0100
@@ -2293,6 +2293,11 @@ dwarf2_evaluate_loc_desc_full (struct ty
int in_stack_memory = dwarf_expr_fetch_in_stack_memory (ctx, 0);
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);
@@ -2552,6 +2557,19 @@ dwarf2_compile_property_to_c (struct ui_
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. */
Reference in New Issue View Git Blame Copy Permalink