[PATCH 00/23] Fortran dynamic array support https://sourceware.org/ml/gdb-patches/2014-06/msg00108.html https://github.com/intel-gdb/vla/tree/vla-fortran GIT snapshot: commit 511bff520372ffc10fa2ff569c176bdf1e6e475d Index: gdb-7.10.50.20151027/gdb/c-valprint.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/c-valprint.c 2015-10-27 02:48:31.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/c-valprint.c 2015-11-03 21:13:35.959339113 +0100 @@ -642,7 +642,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.10.50.20151027/gdb/dwarf2loc.h =================================================================== --- gdb-7.10.50.20151027.orig/gdb/dwarf2loc.h 2015-10-27 02:48:31.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/dwarf2loc.h 2015-11-03 20:41:48.533504941 +0100 @@ -138,6 +138,11 @@ int dwarf2_evaluate_property (const stru struct property_addr_info *addr_stack, CORE_ADDR *value); +/* Checks if a dwarf location definition is valid. + Returns 1 if valid; 0 otherwise. */ + +extern int dwarf2_address_data_valid (const struct type *type); + /* A helper for the compiler interface that compiles a single dynamic property to C code. Index: gdb-7.10.50.20151027/gdb/dwarf2read.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/dwarf2read.c 2015-10-27 02:48:31.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/dwarf2read.c 2015-11-03 21:13:38.216349800 +0100 @@ -1745,7 +1745,9 @@ static void read_signatured_type (struct static int attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die, struct dwarf2_cu *cu, - struct dynamic_prop *prop); + struct dynamic_prop *prop, + const gdb_byte *additional_data, + int additional_data_size); /* memory allocation interface */ @@ -11420,7 +11422,7 @@ read_func_scope (struct die_info *die, s { newobj->static_link = XOBNEW (&objfile->objfile_obstack, struct dynamic_prop); - attr_to_dynamic_prop (attr, die, cu, newobj->static_link); + attr_to_dynamic_prop (attr, die, cu, newobj->static_link, NULL, 0); } cu->list_in_scope = &local_symbols; @@ -14471,29 +14473,92 @@ 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); @@ -14816,13 +14881,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; @@ -14835,8 +14902,25 @@ attr_to_dynamic_prop (const struct attri baton = XOBNEW (obstack, struct dwarf2_property_baton); baton->referenced_type = NULL; baton->locexpr.per_cu = cu->per_cu; - baton->locexpr.size = DW_BLOCK (attr)->size; - baton->locexpr.data = DW_BLOCK (attr)->data; + + if (additional_data != NULL && additional_data_size > 0) + { + gdb_byte *data; + + data = obstack_alloc (&cu->objfile->objfile_obstack, + DW_BLOCK (attr)->size + additional_data_size); + memcpy (data, DW_BLOCK (attr)->data, DW_BLOCK (attr)->size); + memcpy (data + DW_BLOCK (attr)->size, + additional_data, additional_data_size); + + baton->locexpr.data = data; + baton->locexpr.size = DW_BLOCK (attr)->size + additional_data_size; + } + else + { + baton->locexpr.data = DW_BLOCK (attr)->data; + baton->locexpr.size = DW_BLOCK (attr)->size; + } prop->data.baton = baton; prop->kind = PROP_LOCEXPR; gdb_assert (prop->data.baton != NULL); @@ -14872,8 +14956,28 @@ attr_to_dynamic_prop (const struct attri baton = XOBNEW (obstack, struct dwarf2_property_baton); baton->referenced_type = die_type (target_die, target_cu); baton->locexpr.per_cu = cu->per_cu; - baton->locexpr.size = DW_BLOCK (target_attr)->size; - baton->locexpr.data = DW_BLOCK (target_attr)->data; + + if (additional_data != NULL && additional_data_size > 0) + { + gdb_byte *data; + + data = obstack_alloc (&cu->objfile->objfile_obstack, + DW_BLOCK (target_attr)->size + additional_data_size); + memcpy (data, DW_BLOCK (target_attr)->data, + DW_BLOCK (target_attr)->size); + memcpy (data + DW_BLOCK (target_attr)->size, + additional_data, additional_data_size); + + baton->locexpr.data = data; + baton->locexpr.size = (DW_BLOCK (target_attr)->size + + additional_data_size); + } + else + { + baton->locexpr.data = DW_BLOCK (target_attr)->data; + baton->locexpr.size = DW_BLOCK (target_attr)->size; + } + prop->data.baton = baton; prop->kind = PROP_LOCEXPR; gdb_assert (prop->data.baton != NULL); @@ -14927,7 +15031,7 @@ 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; @@ -14947,7 +15051,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. */ @@ -14980,19 +15086,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) @@ -15056,7 +15169,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; @@ -22360,7 +22473,7 @@ set_die_type (struct die_info *die, stru attr = dwarf2_attr (die, DW_AT_allocated, cu); if (attr_form_is_block (attr)) { - if (attr_to_dynamic_prop (attr, die, cu, &prop)) + if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0)) add_dyn_prop (DYN_PROP_ALLOCATED, prop, type, objfile); } else if (attr != NULL) @@ -22375,7 +22488,7 @@ set_die_type (struct die_info *die, stru attr = dwarf2_attr (die, DW_AT_associated, cu); if (attr_form_is_block (attr)) { - if (attr_to_dynamic_prop (attr, die, cu, &prop)) + if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0)) add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type, objfile); } else if (attr != NULL) @@ -22388,7 +22501,7 @@ 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)) add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type, objfile); if (dwarf2_per_objfile->die_type_hash == NULL) Index: gdb-7.10.50.20151027/gdb/f-typeprint.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/f-typeprint.c 2015-10-27 02:48:31.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/f-typeprint.c 2015-11-03 21:13:35.707337920 +0100 @@ -31,6 +31,7 @@ #include "target.h" #include "f-lang.h" #include "typeprint.h" +#include "valprint.h" #if 0 /* Currently unused. */ static void f_type_print_args (struct type *, struct ui_file *); @@ -64,6 +65,17 @@ f_print_type (struct type *type, const c { val_print_not_allocated (stream); return; + } + + if (TYPE_NOT_ASSOCIATED (type)) + { + val_print_not_associated (stream); + return; + } + if (TYPE_NOT_ALLOCATED (type)) + { + val_print_not_allocated (stream); + return; } f_type_print_base (type, stream, show, level); Index: gdb-7.10.50.20151027/gdb/f-valprint.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/f-valprint.c 2015-10-27 02:48:31.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/f-valprint.c 2015-11-03 21:13:35.959339113 +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.10.50.20151027/gdb/gdbtypes.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/gdbtypes.c 2015-10-27 02:48:31.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/gdbtypes.c 2015-11-03 21:13:38.683352011 +0100 @@ -836,7 +836,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); @@ -851,6 +852,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; @@ -879,7 +881,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; @@ -887,7 +889,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; } @@ -1084,16 +1090,21 @@ create_array_type_with_stride (struct ty && (!type_not_associated (result_type) && !type_not_allocated (result_type))) { - LONGEST low_bound, high_bound; + LONGEST low_bound, high_bound, byte_stride; if (get_discrete_bounds (range_type, &low_bound, &high_bound) < 0) low_bound = high_bound = 0; element_type = check_typedef (element_type); + + byte_stride = abs (TYPE_BYTE_STRIDE (range_type)); + /* Be careful when setting the array length. Ada arrays can be empty arrays with the high_bound being smaller than the low_bound. In such cases, the array length should be zero. */ if (high_bound < low_bound) TYPE_LENGTH (result_type) = 0; + else if (byte_stride > 0) + TYPE_LENGTH (result_type) = byte_stride * (high_bound - low_bound + 1); else if (bit_stride > 0) TYPE_LENGTH (result_type) = (bit_stride * (high_bound - low_bound + 1) + 7) / 8; @@ -1804,12 +1815,31 @@ 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; @@ -1844,11 +1874,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: @@ -1861,6 +1899,18 @@ 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 + || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)) + return is_dynamic_type (check_typedef (TYPE_TARGET_TYPE (type))); + + return 0; + break; + } + default: + return 0; break; } @@ -1890,7 +1940,8 @@ resolve_dynamic_range (struct type *dyn_ struct type *static_range_type, *static_target_type; const struct dynamic_prop *prop; const struct dwarf2_locexpr_baton *baton; - struct dynamic_prop low_bound, high_bound; + struct dynamic_prop low_bound, high_bound, stride; + struct type *range_copy = copy_type (dyn_range_type); gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE); @@ -1922,12 +1973,19 @@ resolve_dynamic_range (struct type *dyn_ high_bound.data.const_val = 0; } + prop = &TYPE_RANGE_DATA (dyn_range_type)->stride; + if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value)) + { + stride.kind = PROP_CONST; + stride.data.const_val = value; + } + static_target_type - = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (dyn_range_type), + = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (range_copy), addr_stack, 0); - static_range_type = create_range_type (copy_type (dyn_range_type), + static_range_type = create_range_type (range_copy, static_target_type, - &low_bound, &high_bound); + &low_bound, &high_bound, &stride); TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1; return static_range_type; } @@ -1946,7 +2004,8 @@ resolve_dynamic_array (struct type *type struct type *ary_dim; struct dynamic_prop *prop; - gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY); + gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY + || TYPE_CODE (type) == TYPE_CODE_STRING); type = copy_type (type); @@ -1971,13 +2030,18 @@ resolve_dynamic_array (struct type *type ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type)); - if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY) + if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY + || TYPE_CODE (ary_dim) == TYPE_CODE_STRING)) elt_type = resolve_dynamic_array (ary_dim, addr_stack); else elt_type = TYPE_TARGET_TYPE (type); - return create_array_type_with_stride (type, elt_type, range_type, - TYPE_FIELD_BITSIZE (type, 0)); + if (TYPE_CODE (type) == TYPE_CODE_STRING + && TYPE_FIELD_BITSIZE (type, 0) == 0) + return create_string_type (type, elt_type, range_type); + else + return create_array_type_with_stride (type, elt_type, range_type, + TYPE_FIELD_BITSIZE (type, 0)); } /* Resolve dynamic bounds of members of the union TYPE to static @@ -4558,6 +4622,17 @@ copy_type_recursive (struct objfile *obj gdb_assert_not_reached ("bad type_specific_kind"); } + 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.10.50.20151027/gdb/gdbtypes.h =================================================================== --- gdb-7.10.50.20151027.orig/gdb/gdbtypes.h 2015-10-27 02:48:31.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/gdbtypes.h 2015-11-03 21:13:36.760342906 +0100 @@ -577,6 +577,10 @@ struct range_bounds struct dynamic_prop high; + /* * Stride of range. */ + + struct dynamic_prop stride; + /* True if HIGH range bound contains the number of elements in the subrange. This affects how the final hight bound is computed. */ @@ -749,6 +753,18 @@ struct main_type /* * Contains all dynamic type properties. */ struct dynamic_prop_list *dyn_prop_list; + + /* Structure for DW_AT_allocated. + The presence of this attribute indicates that the object of the type + can be allocated/deallocated. The value can be a dwarf expression, + reference, or a constant. */ + struct dynamic_prop *allocated; + + /* Structure for DW_AT_associated. + The presence of this attribute indicated that the object of the type + can be associated. The value can be a dwarf expression, + reference, or a constant. */ + struct dynamic_prop *associated; }; /* * A ``struct type'' describes a particular instance of a type, with @@ -1255,6 +1271,15 @@ 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 + /* Property accessors for the type data location. */ #define TYPE_DATA_LOCATION(thistype) \ @@ -1266,6 +1291,18 @@ extern void allocate_gnat_aux_type (stru #define TYPE_DATA_LOCATION_KIND(thistype) \ TYPE_DATA_LOCATION (thistype)->kind +/* Allocated status of type object. If set to non-zero it means the object + is allocated. A zero value means it is not allocated. */ +#define TYPE_NOT_ALLOCATED(t) (TYPE_ALLOCATED_PROP (t) \ + && TYPE_ALLOCATED_PROP (t)->kind == PROP_CONST \ + && !TYPE_ALLOCATED_PROP (t)->data.const_val) + +/* Associated status of type object. If set to non-zero it means the object + is associated. A zero value means it is not associated. */ +#define TYPE_NOT_ASSOCIATED(t) (TYPE_ASSOCIATED_PROP (t) \ + && TYPE_ASSOCIATED_PROP (t)->kind == PROP_CONST \ + && !TYPE_ASSOCIATED_PROP (t)->data.const_val) + /* Property accessors for the type allocated/associated. */ #define TYPE_ALLOCATED_PROP(thistype) \ get_dyn_prop (DYN_PROP_ALLOCATED, thistype) @@ -1289,6 +1326,9 @@ 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)))) @@ -1775,6 +1815,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.10.50.20151027/gdb/testsuite/gdb.fortran/vla-func.exp =================================================================== --- /dev/null 1970-01-01 00:00:00.000000000 +0000 +++ gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-func.exp 2015-11-03 20:41:48.542504993 +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 . + +standard_testfile ".f90" + +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ + {debug f90 quiet}] } { + return -1 +} + +if ![runto MAIN__] then { + perror "couldn't run to breakpoint MAIN__" + continue +} + +# Check VLA passed to first Fortran function. +gdb_breakpoint [gdb_get_line_number "func1-vla-passed"] +gdb_continue_to_breakpoint "func1-vla-passed" +gdb_test "print vla" " = \\( *\\( *22, *22, *22,\[()22, .\]*\\)" \ + "print vla (func1)" +gdb_test "ptype vla" "type = integer\\\(kind=4\\\) \\\(10,10\\\)" \ + "ptype vla (func1)" + +gdb_breakpoint [gdb_get_line_number "func1-vla-modified"] +gdb_continue_to_breakpoint "func1-vla-modified" +gdb_test "print vla(5,5)" " = 55" "print vla(5,5) (func1)" +gdb_test "print vla(7,7)" " = 77" "print vla(5,5) (func1)" + +# Check if the values are correct after returning from func1 +gdb_breakpoint [gdb_get_line_number "func1-returned"] +gdb_continue_to_breakpoint "func1-returned" +gdb_test "print ret" " = .TRUE." "print ret after func1 returned" + +# Check VLA passed to second Fortran function +gdb_breakpoint [gdb_get_line_number "func2-vla-passed"] +gdb_continue_to_breakpoint "func2-vla-passed" +gdb_test "print vla" \ + " = \\\(44, 44, 44, 44, 44, 44, 44, 44, 44, 44\\\)" \ + "print vla (func2)" +gdb_test "ptype vla" "type = integer\\\(kind=4\\\) \\\(10\\\)" \ + "ptype vla (func2)" + +# Check if the returned VLA has the correct values and ptype. +gdb_breakpoint [gdb_get_line_number "func2-returned"] +gdb_continue_to_breakpoint "func2-returned" +gdb_test "print vla3" " = \\\(1, 2, 44, 4, 44, 44, 44, 8, 44, 44\\\)" \ + "print vla3 (after func2)" +gdb_test "ptype vla3" "type = integer\\\(kind=4\\\) \\\(10\\\)" \ + "ptype vla3 (after func2)" Index: gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-func.f90 =================================================================== --- /dev/null 1970-01-01 00:00:00.000000000 +0000 +++ gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-func.f90 2015-11-03 20:41:48.542504993 +0100 @@ -0,0 +1,71 @@ +! Copyright 2014 Free Software Foundation, Inc. +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +logical function func1 (vla) + implicit none + integer, allocatable :: vla (:, :) + func1 = allocated(vla) + vla(5,5) = 55 ! func1-vla-passed + vla(7,7) = 77 + return ! func1-vla-modified +end function func1 + +function func2(vla) + implicit none + integer :: vla (:) + integer :: func2(size(vla)) + integer :: k + + vla(1) = 1 ! func2-vla-passed + vla(2) = 2 + vla(4) = 4 + vla(8) = 8 + + func2 = vla +end function func2 + +program vla_func + implicit none + interface + logical function func1 (vla) + integer :: vla (:, :) + end function + end interface + interface + function func2 (vla) + integer :: vla (:) + integer func2(size(vla)) + end function + end interface + + logical :: ret + integer, allocatable :: vla1 (:, :) + integer, allocatable :: vla2 (:) + integer, allocatable :: vla3 (:) + + ret = .FALSE. + + allocate (vla1 (10,10)) + vla1(:,:) = 22 + + allocate (vla2 (10)) + vla2(:) = 44 + + ret = func1(vla1) + vla3 = func2(vla2) ! func1-returned + + ret = .TRUE. ! func2-returned +end program vla_func Index: gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-stride.exp =================================================================== --- /dev/null 1970-01-01 00:00:00.000000000 +0000 +++ gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-stride.exp 2015-11-03 20:41:48.542504993 +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 . + +standard_testfile ".f90" + +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ + {debug f90 quiet}] } { + return -1 +} + +if ![runto MAIN__] then { + perror "couldn't run to breakpoint MAIN__" + continue +} + +gdb_breakpoint [gdb_get_line_number "re-reverse-elements"] +gdb_continue_to_breakpoint "re-reverse-elements" +gdb_test "print pvla" " = \\\(1, 2, 3, 4, 5, 6, 7, 8, 9, 10\\\)" \ + "print re-reverse-elements" +gdb_test "print pvla(1)" " = 1" "print first re-reverse-element" +gdb_test "print pvla(10)" " = 10" "print last re-reverse-element" + +gdb_breakpoint [gdb_get_line_number "odd-elements"] +gdb_continue_to_breakpoint "odd-elements" +gdb_test "print pvla" " = \\\(1, 3, 5, 7, 9\\\)" "print odd-elements" +gdb_test "print pvla(1)" " = 1" "print first odd-element" +gdb_test "print pvla(5)" " = 9" "print last odd-element" + +gdb_breakpoint [gdb_get_line_number "single-element"] +gdb_continue_to_breakpoint "single-element" +gdb_test "print pvla" " = \\\(5\\\)" "print single-element" +gdb_test "print pvla(1)" " = 5" "print one single-element" Index: gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-stride.f90 =================================================================== --- /dev/null 1970-01-01 00:00:00.000000000 +0000 +++ gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-stride.f90 2015-11-03 20:41:48.543504999 +0100 @@ -0,0 +1,30 @@ +! Copyright 2014 Free Software Foundation, Inc. +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +program vla_stride + integer, target, allocatable :: vla (:) + integer, pointer :: pvla (:) + + allocate(vla(10)) + vla = (/ (I, I = 1,10) /) + + pvla => vla(10:1:-1) + pvla => pvla(10:1:-1) + pvla => vla(1:10:2) ! re-reverse-elements + pvla => vla(5:4:-2) ! odd-elements + + pvla => null() ! single-element +end program vla_stride Index: gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-strings.exp =================================================================== --- /dev/null 1970-01-01 00:00:00.000000000 +0000 +++ gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-strings.exp 2015-11-03 21:13:45.863386007 +0100 @@ -0,0 +1,101 @@ +# Copyright 2014 Free Software Foundation, Inc. + +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 3 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program. If not, see . + +standard_testfile ".f90" + +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ + {debug f90 quiet}] } { + return -1 +} + +# check that all fortran standard datatypes will be +# handled correctly when using as VLA's + +if ![runto MAIN__] then { + perror "couldn't run to breakpoint MAIN__" + continue +} + +gdb_breakpoint [gdb_get_line_number "var_char-allocated-1"] +gdb_continue_to_breakpoint "var_char-allocated-1" +gdb_test "print var_char" \ + " = \\(PTR TO -> \\( character\\*10 \\)\\) ${hex}" \ + "print var_char after allocated first time" +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*10 \\)" \ + "whatis var_char first time" +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*10 \\)" \ + "ptype var_char first time" +gdb_test "next" "\\d+.*var_char = 'foo'.*" \ + "next to allocation status of var_char" +gdb_test "print l" " = .TRUE." "print allocation status first time" + +gdb_breakpoint [gdb_get_line_number "var_char-filled-1"] +gdb_continue_to_breakpoint "var_char-filled-1" +gdb_test "print var_char" \ + " = \\(PTR TO -> \\( character\\*3 \\)\\) ${hex}" \ + "print var_char after filled first time" +gdb_test "print *var_char" " = 'foo'" \ + "print *var_char after filled first time" +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*3 \\)" \ + "whatis var_char after filled first time" +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*3 \\)" \ + "ptype var_char after filled first time" +gdb_test "print var_char(1)" " = 102 'f'" "print var_char(1)" +gdb_test "print var_char(3)" " = 111 'o'" "print var_char(3)" + +gdb_breakpoint [gdb_get_line_number "var_char-filled-2"] +gdb_continue_to_breakpoint "var_char-filled-2" +gdb_test "print var_char" \ + " = \\(PTR TO -> \\( character\\*6 \\)\\) ${hex}" \ + "print var_char after allocated second time" +gdb_test "print *var_char" " = 'foobar'" \ + "print *var_char after allocated second time" +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*6 \\)" \ + "whatis var_char second time" +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*6 \\)" \ + "ptype var_char second time" + +gdb_breakpoint [gdb_get_line_number "var_char-empty"] +gdb_continue_to_breakpoint "var_char-empty" +gdb_test "print var_char" \ + " = \\(PTR TO -> \\( character\\*0 \\)\\) ${hex}" \ + "print var_char after set empty" +gdb_test "print *var_char" " = \"\"" "print *var_char after set empty" +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*0 \\)" \ + "whatis var_char after set empty" +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*0 \\)" \ + "ptype var_char after set empty" + +gdb_breakpoint [gdb_get_line_number "var_char-allocated-3"] +gdb_continue_to_breakpoint "var_char-allocated-3" +gdb_test "print var_char" \ + " = \\(PTR TO -> \\( character\\*21 \\)\\) ${hex}" \ + "print var_char after allocated third time" +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*21 \\)" \ + "whatis var_char after allocated third time" +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*21 \\)" \ + "ptype var_char after allocated third time" + +gdb_breakpoint [gdb_get_line_number "var_char_p-associated"] +gdb_continue_to_breakpoint "var_char_p-associated" +gdb_test "print var_char_p" \ + " = \\(PTR TO -> \\( character\\*7 \\)\\) ${hex}" \ + "print var_char_p after associated" +gdb_test "print *var_char_p" " = 'johndoe'" \ + "print *var_char_ after associated" +gdb_test "whatis var_char_p" "type = PTR TO -> \\( character\\*7 \\)" \ + "whatis var_char_p after associated" +gdb_test "ptype var_char_p" "type = PTR TO -> \\( character\\*7 \\)" \ + "ptype var_char_p after associated" Index: gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-strings.f90 =================================================================== --- /dev/null 1970-01-01 00:00:00.000000000 +0000 +++ gdb-7.10.50.20151027/gdb/testsuite/gdb.fortran/vla-strings.f90 2015-11-03 20:41:48.543504999 +0100 @@ -0,0 +1,40 @@ +! Copyright 2014 Free Software Foundation, Inc. +! +! This program is free software; you can redistribute it and/or modify +! it under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2 of the License, or +! (at your option) any later version. +! +! This program is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + +program vla_strings + character(len=:), target, allocatable :: var_char + character(len=:), pointer :: var_char_p + logical :: l + + allocate(character(len=10) :: var_char) + l = allocated(var_char) ! var_char-allocated-1 + var_char = 'foo' + deallocate(var_char) ! var_char-filled-1 + l = allocated(var_char) ! var_char-deallocated + allocate(character(len=42) :: var_char) + l = allocated(var_char) + var_char = 'foobar' + var_char = '' ! var_char-filled-2 + var_char = 'bar' ! var_char-empty + deallocate(var_char) + allocate(character(len=21) :: var_char) + l = allocated(var_char) ! var_char-allocated-3 + var_char = 'johndoe' + var_char_p => var_char + l = associated(var_char_p) ! var_char_p-associated + var_char_p => null() + l = associated(var_char_p) ! var_char_p-not-associated +end program vla_strings Index: gdb-7.10.50.20151027/gdb/typeprint.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/typeprint.c 2015-10-27 02:48:32.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/typeprint.c 2015-11-03 21:13:35.959339113 +0100 @@ -460,6 +460,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.10.50.20151027/gdb/valarith.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/valarith.c 2015-10-27 02:48:32.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/valarith.c 2015-11-03 21:13:38.625351736 +0100 @@ -193,9 +193,21 @@ 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_units (elt_type); - unsigned int elt_offs = elt_size * longest_to_int (index - lowerbound); + unsigned int elt_offs = longest_to_int (index - lowerbound); + LONGEST elt_stride = TYPE_BYTE_STRIDE (TYPE_INDEX_TYPE (array_type)); struct value *v; + if (elt_stride > 0) + elt_offs *= elt_stride; + else if (elt_stride < 0) + { + int offs = (elt_offs + 1) * elt_stride; + + elt_offs = TYPE_LENGTH (array_type) + offs; + } + else + elt_offs *= elt_size; + if (index < lowerbound || (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type) && elt_offs >= type_length_units (array_type))) { Index: gdb-7.10.50.20151027/gdb/valprint.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/valprint.c 2015-10-27 02:48:32.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/valprint.c 2015-11-03 21:13:35.959339113 +0100 @@ -316,6 +316,18 @@ valprint_check_validity (struct ui_file return 0; } + if (TYPE_NOT_ASSOCIATED (type)) + { + val_print_not_associated (stream); + return 0; + } + + if (TYPE_NOT_ALLOCATED (type)) + { + val_print_not_allocated (stream); + return 0; + } + if (TYPE_CODE (type) != TYPE_CODE_UNION && TYPE_CODE (type) != TYPE_CODE_STRUCT && TYPE_CODE (type) != TYPE_CODE_ARRAY) @@ -1025,12 +1037,16 @@ 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, _("
")); return 0; } + type = value_type (val); + if (value_entirely_optimized_out (val)) { if (options->summary && !val_print_scalar_type_p (value_type (val))) @@ -1066,6 +1082,18 @@ value_check_printable (struct value *val { val_print_not_allocated (stream); return 0; + } + + if (TYPE_NOT_ASSOCIATED (type)) + { + val_print_not_associated (stream); + return 0; + } + + if (TYPE_NOT_ALLOCATED (type)) + { + val_print_not_allocated (stream); + return 0; } return 1; Index: gdb-7.10.50.20151027/gdb/valprint.h =================================================================== --- gdb-7.10.50.20151027.orig/gdb/valprint.h 2015-10-27 02:48:32.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/valprint.h 2015-11-03 21:13:35.959339113 +0100 @@ -232,4 +232,8 @@ extern void print_command_parse_format ( struct format_data *fmtp); extern void print_value (struct value *val, const struct format_data *fmtp); +extern void val_print_not_allocated (struct ui_file *stream); + +extern void val_print_not_associated (struct ui_file *stream); + #endif Index: gdb-7.10.50.20151027/gdb/value.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/value.c 2015-10-27 02:48:32.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/value.c 2015-11-03 21:13:38.731352238 +0100 @@ -40,6 +40,7 @@ #include "tracepoint.h" #include "cp-abi.h" #include "user-regs.h" +#include "dwarf2loc.h" /* Prototypes for exported functions. */ @@ -1788,6 +1789,25 @@ 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); + } + } } @@ -3095,13 +3115,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_units (type)); + if (TYPE_DATA_LOCATION (type) + && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST) + v = value_at_lazy (type, value_address (arg1) + offset); + else + { + v = allocate_value (type); + value_contents_copy_raw (v, value_embedded_offset (v), + arg1, value_embedded_offset (arg1) + offset, + type_length_units (type)); + } } - v->offset = (value_offset (arg1) + offset - + value_embedded_offset (arg1)); + + if (!TYPE_DATA_LOCATION (type) + || !TYPE_DATA_LOCATION_KIND (type) == PROP_CONST) + v->offset = (value_offset (arg1) + offset + + value_embedded_offset (arg1)); } set_value_component_location (v, arg1); VALUE_REGNUM (v) = VALUE_REGNUM (arg1); @@ -3689,7 +3718,8 @@ 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); @@ -3706,6 +3736,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; @@ -3834,8 +3870,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.10.50.20151027/gdb/dwarf2loc.c =================================================================== --- gdb-7.10.50.20151027.orig/gdb/dwarf2loc.c 2015-10-27 02:48:31.000000000 +0100 +++ gdb-7.10.50.20151027/gdb/dwarf2loc.c 2015-11-03 21:13:35.959339113 +0100 @@ -2347,6 +2347,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); @@ -2639,6 +2644,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. */