Subject: [PATCH 04/23] vla: make dynamic fortran arrays functional. Message-Id: <1401861266-6240-5-git-send-email-keven.boell@intel.com> This patch enables GDB to print the value of a dynamic array (VLA) if allocated/associated in fortran. If not the allocation status will be printed to the command line. (gdb) p vla_not_allocated $1 = (gdb) p vla_allocated $1 = (1, 2, 3) (gdb) p vla_not_associated $1 = (gdb) p vla_associated $1 = (3, 2, 1) The patch covers various locations where the allocation/ association status makes sense to print. 2014-05-28 Keven Boell Sanimir Agovic * dwarf2loc.c (dwarf2_address_data_valid): New function. * dwarf2loc.h (dwarf2_address_data_valid): New function. * f-typeprint.c (f_print_type): Print allocation/ association status. (f_type_print_varspec_suffix): Print allocation/ association status for &-operator usages. * gdbtypes.c (create_array_type_with_stride): Add query for valid data location. (is_dynamic_type): Extend dynamic type detection with allocated/associated. Add type detection for fields. (resolve_dynamic_range): Copy type before resolving it as dynamic attributes need to be preserved. (resolve_dynamic_array): Copy type before resolving it as dynamic attributes need to be preserved. Add resolving of allocated/associated attributes. (resolve_dynamic_type): Add call to nested type resolving. (copy_type_recursive): Add allocated/associated attributes to be copied. (copy_type): Copy allocated/associated/data_location as well as the fields structure if available. (resolve_dynamic_compound): New function. * valarith.c (value_subscripted_rvalue): Print allocated/ associated status when indexing a VLA. * valprint.c (valprint_check_validity): Print allocated/ associated status. (val_print_not_allocated): New function. (val_print_not_associated): New function. * valprint.h (val_print_not_allocated): New function. (val_print_not_associated): New function. * value.c (set_value_component_location): Adjust the value address for single value prints. Change-Id: Idfb44c8a6b38008f8e2c84cb0fdb13729ec160f4 Signed-off-by: Keven Boell --- gdb/dwarf2loc.c | 14 +++++ gdb/dwarf2loc.h | 6 ++ gdb/f-typeprint.c | 62 +++++++++++++------- gdb/gdbtypes.c | 165 +++++++++++++++++++++++++++++++++++++++++++++++++++-- gdb/valarith.c | 9 ++- gdb/valprint.c | 40 +++++++++++++ gdb/valprint.h | 4 ++ gdb/value.c | 20 +++++++ 8 files changed, 292 insertions(+), 28 deletions(-) Index: gdb-7.7.90.20140613/gdb/dwarf2loc.c =================================================================== --- gdb-7.7.90.20140613.orig/gdb/dwarf2loc.c 2014-06-14 15:12:43.797996885 +0200 +++ gdb-7.7.90.20140613/gdb/dwarf2loc.c 2014-06-14 15:12:45.485998049 +0200 @@ -2569,6 +2569,20 @@ dwarf2_evaluate_property (const struct d return 0; } +/* 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. */ Index: gdb-7.7.90.20140613/gdb/dwarf2loc.h =================================================================== --- gdb-7.7.90.20140613.orig/gdb/dwarf2loc.h 2014-06-14 15:12:43.797996885 +0200 +++ gdb-7.7.90.20140613/gdb/dwarf2loc.h 2014-06-14 15:12:45.486998064 +0200 @@ -102,6 +102,12 @@ int dwarf2_evaluate_property (const stru CORE_ADDR dwarf2_read_addr_index (struct dwarf2_per_cu_data *per_cu, unsigned int addr_index); +/* Checks if a dwarf location definition is valid. + Returns 1 if valid; 0 otherwise. */ + +extern int dwarf2_address_data_valid (const struct type *type); + + /* The symbol location baton types used by the DWARF-2 reader (i.e. SYMBOL_LOCATION_BATON for a LOC_COMPUTED symbol). "struct dwarf2_locexpr_baton" is for a symbol with a single location Index: gdb-7.7.90.20140613/gdb/f-typeprint.c =================================================================== --- gdb-7.7.90.20140613.orig/gdb/f-typeprint.c 2014-06-14 15:12:43.798996886 +0200 +++ gdb-7.7.90.20140613/gdb/f-typeprint.c 2014-06-14 15:12:45.486998064 +0200 @@ -30,6 +30,7 @@ #include "gdbcore.h" #include "target.h" #include "f-lang.h" +#include "valprint.h" #include #include @@ -56,6 +57,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') @@ -170,28 +182,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.7.90.20140613/gdb/gdbtypes.c =================================================================== --- gdb-7.7.90.20140613.orig/gdb/gdbtypes.c 2014-06-14 15:12:43.801996888 +0200 +++ gdb-7.7.90.20140613/gdb/gdbtypes.c 2014-06-14 15:14:34.837102369 +0200 @@ -1003,7 +1003,8 @@ 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; @@ -1616,11 +1617,30 @@ stub_noname_complaint (void) int is_dynamic_type (struct type *type) { + int index; + + if (!type) + return 0; + type = check_typedef (type); if (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; + switch (TYPE_CODE (type)) { case TYPE_CODE_RANGE: @@ -1669,6 +1689,7 @@ resolve_dynamic_range (struct type *dyn_ const struct dynamic_prop *prop; const struct dwarf2_locexpr_baton *baton; struct dynamic_prop low_bound, high_bound; + struct type *range_copy = copy_type (dyn_range_type); gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE); @@ -1700,8 +1721,8 @@ resolve_dynamic_range (struct type *dyn_ high_bound.data.const_val = 0; } - static_range_type = create_range_type (copy_type (dyn_range_type), - TYPE_TARGET_TYPE (dyn_range_type), + static_range_type = create_range_type (range_copy, + TYPE_TARGET_TYPE (range_copy), &low_bound, &high_bound); TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1; return static_range_type; @@ -1718,6 +1739,8 @@ 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); @@ -1725,18 +1748,93 @@ resolve_dynamic_array (struct 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); + elt_type = resolve_dynamic_array (TYPE_TARGET_TYPE (copy), addr); else elt_type = TYPE_TARGET_TYPE (type); - return create_array_type (copy_type (type), + return create_array_type (copy, elt_type, range_type); } +/* Resolves dynamic compound types, e.g. STRUCTS's to static ones. + ADDRESS is needed to resolve the compound type data location. */ + +static struct type * +resolve_dynamic_compound (struct type *type, CORE_ADDR addr) +{ + struct type *cur_type, *prev_type, *copy; + int index, depth = 0; + + cur_type = type; + prev_type = cur_type; + while (cur_type) + { + switch (TYPE_CODE (cur_type)) + { + case TYPE_CODE_STRUCT: + { + copy = copy_type (cur_type); + for (index = 0; index < TYPE_NFIELDS (copy); index++) + { + struct type *index_type = TYPE_FIELD_TYPE (copy, index); + + if (index_type == NULL) + continue; + + if (TYPE_CODE (index_type) == TYPE_CODE_ARRAY + || TYPE_CODE (index_type) == TYPE_CODE_STRUCT) + { + if (TYPE_CODE (index_type) != TYPE_CODE_RANGE) + addr += + (TYPE_FIELD_BITPOS (copy, index) / 8); + + TYPE_FIELD_TYPE (copy, index) = + resolve_dynamic_type (TYPE_FIELD_TYPE (copy, index), + addr); + } + } + + /* If a struct type will be resolved as the first type, we need + to assign it back the resolved_type. In the other case it can + be that we have a struct, which is nested in another type. + Therefore we need to preserve the previous type, to assign the + new resolved type as the previous' target type. */ + if (depth == 0) + type = copy; + else + TYPE_TARGET_TYPE (prev_type) = copy; + } + break; + } + + /* Store the previous type, in order to assign resolved types back to + the right target type. */ + prev_type = cur_type; + cur_type = TYPE_TARGET_TYPE (cur_type); + depth++; + }; + + return type; +} + /* Resolve dynamic bounds of members of the union TYPE to static bounds. */ @@ -1836,7 +1934,7 @@ resolve_dynamic_type (struct type *type, struct type *real_type = check_typedef (type); struct type *resolved_type = type; const struct dynamic_prop *prop; - CORE_ADDR value; + CORE_ADDR value, adjusted_address = addr; if (!is_dynamic_type (real_type)) return type; @@ -1882,12 +1980,15 @@ resolve_dynamic_type (struct type *type, prop = TYPE_DATA_LOCATION (type); if (dwarf2_evaluate_property (prop, addr, &value)) { + adjusted_address = value; TYPE_DATA_LOCATION_ADDR (type) = value; TYPE_DATA_LOCATION_KIND (type) = PROP_CONST; } else TYPE_DATA_LOCATION (type) = NULL; + resolved_type = resolve_dynamic_compound (type, adjusted_address); + return resolved_type; } @@ -4104,6 +4205,20 @@ copy_type_recursive (struct objfile *obj *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) = @@ -4150,6 +4265,44 @@ copy_type (const struct type *type) memcpy (TYPE_MAIN_TYPE (new_type), TYPE_MAIN_TYPE (type), sizeof (struct main_type)); + 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.7.90.20140613/gdb/valarith.c =================================================================== --- gdb-7.7.90.20140613.orig/gdb/valarith.c 2014-06-14 15:12:43.801996888 +0200 +++ gdb-7.7.90.20140613/gdb/valarith.c 2014-06-14 15:12:45.488998075 +0200 @@ -200,7 +200,14 @@ value_subscripted_rvalue (struct value * 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.7.90.20140613/gdb/valprint.c =================================================================== --- gdb-7.7.90.20140613.orig/gdb/valprint.c 2014-06-14 15:12:43.802996888 +0200 +++ gdb-7.7.90.20140613/gdb/valprint.c 2014-06-14 15:12:45.488998075 +0200 @@ -307,6 +307,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) @@ -362,6 +374,18 @@ val_print_invalid_address (struct ui_fil fprintf_filtered (stream, _("")); } +void +val_print_not_allocated (struct ui_file *stream) +{ + fprintf_filtered (stream, _("")); +} + +void +val_print_not_associated (struct ui_file *stream) +{ + fprintf_filtered (stream, _("")); +} + /* 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 @@ -803,12 +827,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))) @@ -834,6 +862,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.7.90.20140613/gdb/valprint.h =================================================================== --- gdb-7.7.90.20140613.orig/gdb/valprint.h 2014-06-14 15:12:43.803996889 +0200 +++ gdb-7.7.90.20140613/gdb/valprint.h 2014-06-14 15:12:45.489998073 +0200 @@ -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.7.90.20140613/gdb/value.c =================================================================== --- gdb-7.7.90.20140613.orig/gdb/value.c 2014-06-14 15:12:43.804996890 +0200 +++ gdb-7.7.90.20140613/gdb/value.c 2014-06-14 15:12:45.490998069 +0200 @@ -43,6 +43,7 @@ #include "tracepoint.h" #include "cp-abi.h" #include "user-regs.h" +#include "dwarf2loc.h" /* Prototypes for exported functions. */ @@ -1646,6 +1647,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); + } + } }