gdb-vla-intel.patch

   1 [PATCH 00/23] Fortran dynamic array support
   2 https://sourceware.org/ml/gdb-patches/2014-06/msg00108.html
   3 https://github.com/intel-gdb/vla/tree/vla-fortran
   4
   5 GIT snapshot:
   6 commit 511bff520372ffc10fa2ff569c176bdf1e6e475d
   7
   8
   9 Index: gdb-7.10.50.20160106/gdb/c-valprint.c
  10 ===================================================================
  11 --- gdb-7.10.50.20160106.orig/gdb/c-valprint.c  2016-01-08 19:15:35.065582359 +0100
  12 +++ gdb-7.10.50.20160106/gdb/c-valprint.c       2016-01-08 19:15:44.974637630 +0100
  13 @@ -642,7 +642,16 @@
  14         {
  15           /* normal case */
  16           fprintf_filtered (stream, "(");
  17 -         type_print (value_type (val), "", stream, -1);
  18 +         if (is_dynamic_type (TYPE_TARGET_TYPE (type)))
  19 +           {
  20 +             struct value *v;
  21 +
  22 +             v = value_ind (val);
  23 +             v = value_addr (v);
  24 +             type_print (value_type (v), "", stream, -1);
  25 +           }
  26 +         else
  27 +           type_print (value_type (val), "", stream, -1);
  28           fprintf_filtered (stream, ") ");
  29         }
  30      }
  31 Index: gdb-7.10.50.20160106/gdb/dwarf2loc.h
  32 ===================================================================
  33 --- gdb-7.10.50.20160106.orig/gdb/dwarf2loc.h   2016-01-08 19:15:35.066582365 +0100
  34 +++ gdb-7.10.50.20160106/gdb/dwarf2loc.h        2016-01-08 19:15:44.974637630 +0100
  35 @@ -138,6 +138,11 @@
  36                               struct property_addr_info *addr_stack,
  37                               CORE_ADDR *value);
  38
  39 +/* Checks if a dwarf location definition is valid.
  40 +   Returns 1 if valid; 0 otherwise.  */
  41 +
  42 +extern int dwarf2_address_data_valid (const struct type *type);
  43 +
  44  /* A helper for the compiler interface that compiles a single dynamic
  45     property to C code.
  46
  47 Index: gdb-7.10.50.20160106/gdb/dwarf2read.c
  48 ===================================================================
  49 --- gdb-7.10.50.20160106.orig/gdb/dwarf2read.c  2016-01-08 19:15:35.078582432 +0100
  50 +++ gdb-7.10.50.20160106/gdb/dwarf2read.c       2016-01-08 19:15:44.980637663 +0100
  51 @@ -1745,7 +1745,9 @@
  52
  53  static int attr_to_dynamic_prop (const struct attribute *attr,
  54                                  struct die_info *die, struct dwarf2_cu *cu,
  55 -                                struct dynamic_prop *prop);
  56 +                                struct dynamic_prop *prop,
  57 +                                const gdb_byte *additional_data,
  58 +                                int additional_data_size);
  59
  60  /* memory allocation interface */
  61
  62 @@ -11420,7 +11422,7 @@
  63      {
  64        newobj->static_link
  65         = XOBNEW (&objfile->objfile_obstack, struct dynamic_prop);
  66 -      attr_to_dynamic_prop (attr, die, cu, newobj->static_link);
  67 +      attr_to_dynamic_prop (attr, die, cu, newobj->static_link, NULL, 0);
  68      }
  69
  70    cu->list_in_scope = &local_symbols;
  71 @@ -14471,29 +14473,92 @@
  72    struct gdbarch *gdbarch = get_objfile_arch (objfile);
  73    struct type *type, *range_type, *index_type, *char_type;
  74    struct attribute *attr;
  75 -  unsigned int length;
  76 +  unsigned int length = UINT_MAX;
  77
  78 +  index_type = objfile_type (objfile)->builtin_int;
  79 +  range_type = create_static_range_type (NULL, index_type, 1, length);
  80 +
  81 +  /* If DW_AT_string_length is defined, the length is stored at some location
  82 +   * in memory. */
  83    attr = dwarf2_attr (die, DW_AT_string_length, cu);
  84    if (attr)
  85      {
  86 -      length = DW_UNSND (attr);
  87 +      if (attr_form_is_block (attr))
  88 +        {
  89 +          struct attribute *byte_size, *bit_size;
  90 +          struct dynamic_prop high;
  91 +
  92 +          byte_size = dwarf2_attr (die, DW_AT_byte_size, cu);
  93 +          bit_size = dwarf2_attr (die, DW_AT_bit_size, cu);
  94 +
  95 +          /* DW_AT_byte_size should never occur together in combination with
  96 +             DW_AT_string_length.  */
  97 +          if ((byte_size == NULL && bit_size != NULL) ||
  98 +                  (byte_size != NULL && bit_size == NULL))
  99 +            complaint (&symfile_complaints, _("DW_AT_byte_size AND "
 100 +                      "DW_AT_bit_size found together at the same time."));
 101 +
 102 +          /* If DW_AT_string_length AND DW_AT_byte_size exist together, it
 103 +             describes the number of bytes that should be read from the length
 104 +             memory location.  */
 105 +          if (byte_size != NULL && bit_size == NULL)
 106 +            {
 107 +              /* Build new dwarf2_locexpr_baton structure with additions to the
 108 +                 data attribute, to reflect DWARF specialities to get address
 109 +                 sizes.  */
 110 +              const gdb_byte append_ops[] = {
 111 +                /* DW_OP_deref_size: size of an address on the target machine
 112 +                   (bytes), where the size will be specified by the next
 113 +                   operand.  */
 114 +                DW_OP_deref_size,
 115 +                /* Operand for DW_OP_deref_size.  */
 116 +                DW_UNSND (byte_size) };
 117 +
 118 +              if (!attr_to_dynamic_prop (attr, die, cu, &high,
 119 +                      append_ops, ARRAY_SIZE (append_ops)))
 120 +                complaint (&symfile_complaints,
 121 +                        _("Could not parse DW_AT_byte_size"));
 122 +            }
 123 +          else if (bit_size != NULL && byte_size == NULL)
 124 +            complaint (&symfile_complaints, _("DW_AT_string_length AND "
 125 +                      "DW_AT_bit_size found but not supported yet."));
 126 +          /* If DW_AT_string_length WITHOUT DW_AT_byte_size exist, the default
 127 +             is the address size of the target machine.  */
 128 +          else
 129 +            {
 130 +              const gdb_byte append_ops[] = { DW_OP_deref };
 131 +
 132 +              if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
 133 +                      ARRAY_SIZE (append_ops)))
 134 +                complaint (&symfile_complaints,
 135 +                        _("Could not parse DW_AT_string_length"));
 136 +            }
 137 +
 138 +          TYPE_RANGE_DATA (range_type)->high = high;
 139 +        }
 140 +      else
 141 +        {
 142 +          TYPE_HIGH_BOUND (range_type) = DW_UNSND (attr);
 143 +          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
 144 +        }
 145      }
 146    else
 147      {
 148 -      /* Check for the DW_AT_byte_size attribute.  */
 149 +      /* Check for the DW_AT_byte_size attribute, which represents the length
 150 +         in this case.  */
 151        attr = dwarf2_attr (die, DW_AT_byte_size, cu);
 152        if (attr)
 153          {
 154 -          length = DW_UNSND (attr);
 155 +          TYPE_HIGH_BOUND (range_type) = DW_UNSND (attr);
 156 +          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
 157          }
 158        else
 159          {
 160 -          length = 1;
 161 +          TYPE_HIGH_BOUND (range_type) = 1;
 162 +          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
 163          }
 164      }
 165
 166 -  index_type = objfile_type (objfile)->builtin_int;
 167 -  range_type = create_static_range_type (NULL, index_type, 1, length);
 168    char_type = language_string_char_type (cu->language_defn, gdbarch);
 169    type = create_string_type (NULL, char_type, range_type);
 170
 171 @@ -14816,13 +14881,15 @@
 172    return set_die_type (die, type, cu);
 173  }
 174
 175 +
 176  /* Parse dwarf attribute if it's a block, reference or constant and put the
 177     resulting value of the attribute into struct bound_prop.
 178     Returns 1 if ATTR could be resolved into PROP, 0 otherwise.  */
 179
 180  static int
 181  attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
 182 -                     struct dwarf2_cu *cu, struct dynamic_prop *prop)
 183 +                     struct dwarf2_cu *cu, struct dynamic_prop *prop,
 184 +                     const gdb_byte *additional_data, int additional_data_size)
 185  {
 186    struct dwarf2_property_baton *baton;
 187    struct obstack *obstack = &cu->objfile->objfile_obstack;
 188 @@ -14835,8 +14902,25 @@
 189        baton = XOBNEW (obstack, struct dwarf2_property_baton);
 190        baton->referenced_type = NULL;
 191        baton->locexpr.per_cu = cu->per_cu;
 192 -      baton->locexpr.size = DW_BLOCK (attr)->size;
 193 -      baton->locexpr.data = DW_BLOCK (attr)->data;
 194 +
 195 +      if (additional_data != NULL && additional_data_size > 0)
 196 +        {
 197 +          gdb_byte *data;
 198 +
 199 +          data = obstack_alloc (&cu->objfile->objfile_obstack,
 200 +                  DW_BLOCK (attr)->size + additional_data_size);
 201 +          memcpy (data, DW_BLOCK (attr)->data, DW_BLOCK (attr)->size);
 202 +          memcpy (data + DW_BLOCK (attr)->size,
 203 +                  additional_data, additional_data_size);
 204 +
 205 +          baton->locexpr.data = data;
 206 +          baton->locexpr.size = DW_BLOCK (attr)->size + additional_data_size;
 207 +        }
 208 +      else
 209 +        {
 210 +          baton->locexpr.data = DW_BLOCK (attr)->data;
 211 +          baton->locexpr.size = DW_BLOCK (attr)->size;
 212 +        }
 213        prop->data.baton = baton;
 214        prop->kind = PROP_LOCEXPR;
 215        gdb_assert (prop->data.baton != NULL);
 216 @@ -14872,8 +14956,28 @@
 217                 baton = XOBNEW (obstack, struct dwarf2_property_baton);
 218                 baton->referenced_type = die_type (target_die, target_cu);
 219                 baton->locexpr.per_cu = cu->per_cu;
 220 -               baton->locexpr.size = DW_BLOCK (target_attr)->size;
 221 -               baton->locexpr.data = DW_BLOCK (target_attr)->data;
 222 +
 223 +               if (additional_data != NULL && additional_data_size > 0)
 224 +                 {
 225 +                   gdb_byte *data;
 226 +
 227 +                   data = obstack_alloc (&cu->objfile->objfile_obstack,
 228 +                           DW_BLOCK (target_attr)->size + additional_data_size);
 229 +                   memcpy (data, DW_BLOCK (target_attr)->data,
 230 +                           DW_BLOCK (target_attr)->size);
 231 +                   memcpy (data + DW_BLOCK (target_attr)->size,
 232 +                           additional_data, additional_data_size);
 233 +
 234 +                   baton->locexpr.data = data;
 235 +                   baton->locexpr.size = (DW_BLOCK (target_attr)->size
 236 +                                          + additional_data_size);
 237 +                 }
 238 +               else
 239 +                 {
 240 +                   baton->locexpr.data = DW_BLOCK (target_attr)->data;
 241 +                   baton->locexpr.size = DW_BLOCK (target_attr)->size;
 242 +                 }
 243 +
 244                 prop->data.baton = baton;
 245                 prop->kind = PROP_LOCEXPR;
 246                 gdb_assert (prop->data.baton != NULL);
 247 @@ -14927,7 +15031,7 @@
 248    struct type *base_type, *orig_base_type;
 249    struct type *range_type;
 250    struct attribute *attr;
 251 -  struct dynamic_prop low, high;
 252 +  struct dynamic_prop low, high, stride;
 253    int low_default_is_valid;
 254    int high_bound_is_count = 0;
 255    const char *name;
 256 @@ -14947,7 +15051,9 @@
 257
 258    low.kind = PROP_CONST;
 259    high.kind = PROP_CONST;
 260 +  stride.kind = PROP_CONST;
 261    high.data.const_val = 0;
 262 +  stride.data.const_val = 0;
 263
 264    /* Set LOW_DEFAULT_IS_VALID if current language and DWARF version allow
 265       omitting DW_AT_lower_bound.  */
 266 @@ -14980,19 +15086,26 @@
 267        break;
 268      }
 269
 270 +  attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
 271 +  if (attr)
 272 +    if (!attr_to_dynamic_prop (attr, die, cu, &stride, NULL, 0))
 273 +        complaint (&symfile_complaints, _("Missing DW_AT_byte_stride "
 274 +                  "- DIE at 0x%x [in module %s]"),
 275 +             die->offset.sect_off, objfile_name (cu->objfile));
 276 +
 277    attr = dwarf2_attr (die, DW_AT_lower_bound, cu);
 278    if (attr)
 279 -    attr_to_dynamic_prop (attr, die, cu, &low);
 280 +    attr_to_dynamic_prop (attr, die, cu, &low, NULL, 0);
 281    else if (!low_default_is_valid)
 282      complaint (&symfile_complaints, _("Missing DW_AT_lower_bound "
 283                                       "- DIE at 0x%x [in module %s]"),
 284                die->offset.sect_off, objfile_name (cu->objfile));
 285
 286    attr = dwarf2_attr (die, DW_AT_upper_bound, cu);
 287 -  if (!attr_to_dynamic_prop (attr, die, cu, &high))
 288 +  if (!attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))
 289      {
 290        attr = dwarf2_attr (die, DW_AT_count, cu);
 291 -      if (attr_to_dynamic_prop (attr, die, cu, &high))
 292 +      if (attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))
 293         {
 294           /* If bounds are constant do the final calculation here.  */
 295           if (low.kind == PROP_CONST && high.kind == PROP_CONST)
 296 @@ -15056,7 +15169,7 @@
 297        && !TYPE_UNSIGNED (base_type) && (high.data.const_val & negative_mask))
 298      high.data.const_val |= negative_mask;
 299
 300 -  range_type = create_range_type (NULL, orig_base_type, &low, &high);
 301 +  range_type = create_range_type (NULL, orig_base_type, &low, &high, &stride);
 302
 303    if (high_bound_is_count)
 304      TYPE_RANGE_DATA (range_type)->flag_upper_bound_is_count = 1;
 305 @@ -22360,7 +22473,7 @@
 306    attr = dwarf2_attr (die, DW_AT_allocated, cu);
 307    if (attr_form_is_block (attr))
 308      {
 309 -      if (attr_to_dynamic_prop (attr, die, cu, &prop))
 310 +      if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
 311          add_dyn_prop (DYN_PROP_ALLOCATED, prop, type, objfile);
 312      }
 313    else if (attr != NULL)
 314 @@ -22375,7 +22488,7 @@
 315    attr = dwarf2_attr (die, DW_AT_associated, cu);
 316    if (attr_form_is_block (attr))
 317      {
 318 -      if (attr_to_dynamic_prop (attr, die, cu, &prop))
 319 +      if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
 320          add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type, objfile);
 321      }
 322    else if (attr != NULL)
 323 @@ -22388,7 +22501,7 @@
 324
 325    /* Read DW_AT_data_location and set in type.  */
 326    attr = dwarf2_attr (die, DW_AT_data_location, cu);
 327 -  if (attr_to_dynamic_prop (attr, die, cu, &prop))
 328 +  if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
 329      add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type, objfile);
 330
 331    if (dwarf2_per_objfile->die_type_hash == NULL)
 332 Index: gdb-7.10.50.20160106/gdb/f-typeprint.c
 333 ===================================================================
 334 --- gdb-7.10.50.20160106.orig/gdb/f-typeprint.c 2016-01-08 19:15:35.080582443 +0100
 335 +++ gdb-7.10.50.20160106/gdb/f-typeprint.c      2016-01-08 19:15:44.980637663 +0100
 336 @@ -31,6 +31,7 @@
 337  #include "target.h"
 338  #include "f-lang.h"
 339  #include "typeprint.h"
 340 +#include "valprint.h"
 341
 342  #if 0                          /* Currently unused.  */
 343  static void f_type_print_args (struct type *, struct ui_file *);
 344 @@ -64,6 +65,17 @@
 345      {
 346        val_print_not_allocated (stream);
 347        return;
 348 +    }
 349 +
 350 +  if (TYPE_NOT_ASSOCIATED (type))
 351 +    {
 352 +      val_print_not_associated (stream);
 353 +      return;
 354 +    }
 355 +  if (TYPE_NOT_ALLOCATED (type))
 356 +    {
 357 +      val_print_not_allocated (stream);
 358 +      return;
 359      }
 360
 361    f_type_print_base (type, stream, show, level);
 362 Index: gdb-7.10.50.20160106/gdb/f-valprint.c
 363 ===================================================================
 364 --- gdb-7.10.50.20160106.orig/gdb/f-valprint.c  2016-01-08 19:15:35.081582448 +0100
 365 +++ gdb-7.10.50.20160106/gdb/f-valprint.c       2016-01-08 19:15:44.981637669 +0100
 366 @@ -36,8 +36,6 @@
 367
 368  extern void _initialize_f_valprint (void);
 369  static void info_common_command (char *, int);
 370 -static void f77_create_arrayprint_offset_tbl (struct type *,
 371 -                                             struct ui_file *);
 372  static void f77_get_dynamic_length_of_aggregate (struct type *);
 373
 374  int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
 375 @@ -45,15 +43,6 @@
 376  /* Array which holds offsets to be applied to get a row's elements
 377     for a given array.  Array also holds the size of each subarray.  */
 378
 379 -/* The following macro gives us the size of the nth dimension, Where
 380 -   n is 1 based.  */
 381 -
 382 -#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
 383 -
 384 -/* The following gives us the offset for row n where n is 1-based.  */
 385 -
 386 -#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
 387 -
 388  int
 389  f77_get_lowerbound (struct type *type)
 390  {
 391 @@ -111,47 +100,6 @@
 392      * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
 393  }
 394
 395 -/* Function that sets up the array offset,size table for the array
 396 -   type "type".  */
 397 -
 398 -static void
 399 -f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
 400 -{
 401 -  struct type *tmp_type;
 402 -  int eltlen;
 403 -  int ndimen = 1;
 404 -  int upper, lower;
 405 -
 406 -  tmp_type = type;
 407 -
 408 -  while (TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)
 409 -    {
 410 -      upper = f77_get_upperbound (tmp_type);
 411 -      lower = f77_get_lowerbound (tmp_type);
 412 -
 413 -      F77_DIM_SIZE (ndimen) = upper - lower + 1;
 414 -
 415 -      tmp_type = TYPE_TARGET_TYPE (tmp_type);
 416 -      ndimen++;
 417 -    }
 418 -
 419 -  /* Now we multiply eltlen by all the offsets, so that later we
 420 -     can print out array elements correctly.  Up till now we
 421 -     know an offset to apply to get the item but we also
 422 -     have to know how much to add to get to the next item.  */
 423 -
 424 -  ndimen--;
 425 -  eltlen = TYPE_LENGTH (tmp_type);
 426 -  F77_DIM_OFFSET (ndimen) = eltlen;
 427 -  while (--ndimen > 0)
 428 -    {
 429 -      eltlen *= F77_DIM_SIZE (ndimen + 1);
 430 -      F77_DIM_OFFSET (ndimen) = eltlen;
 431 -    }
 432 -}
 433 -
 434 -
 435 -
 436  /* Actual function which prints out F77 arrays, Valaddr == address in
 437     the superior.  Address == the address in the inferior.  */
 438
 439 @@ -164,41 +112,62 @@
 440                    const struct value_print_options *options,
 441                    int *elts)
 442  {
 443 +  struct type *range_type = TYPE_INDEX_TYPE (check_typedef (type));
 444 +  CORE_ADDR addr = address + embedded_offset;
 445 +  LONGEST lowerbound, upperbound;
 446    int i;
 447
 448 +  get_discrete_bounds (range_type, &lowerbound, &upperbound);
 449 +
 450    if (nss != ndimensions)
 451      {
 452 -      for (i = 0;
 453 -          (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max);
 454 +      size_t dim_size;
 455 +      size_t offs = 0;
 456 +      LONGEST byte_stride = abs (TYPE_BYTE_STRIDE (range_type));
 457 +
 458 +      if (byte_stride)
 459 +        dim_size = byte_stride;
 460 +      else
 461 +        dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));
 462 +
 463 +      for (i = lowerbound;
 464 +          (i < upperbound + 1 && (*elts) < options->print_max);
 465            i++)
 466         {
 467 +         struct value *subarray = value_from_contents_and_address
 468 +           (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val)
 469 +            + offs, addr + offs);
 470 +
 471           fprintf_filtered (stream, "( ");
 472 -         f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
 473 -                            valaddr,
 474 -                            embedded_offset + i * F77_DIM_OFFSET (nss),
 475 -                            address,
 476 -                            stream, recurse, val, options, elts);
 477 +         f77_print_array_1 (nss + 1, ndimensions, value_type (subarray),
 478 +                            value_contents_for_printing (subarray),
 479 +                            value_embedded_offset (subarray),
 480 +                            value_address (subarray),
 481 +                            stream, recurse, subarray, options, elts);
 482 +         offs += dim_size;
 483           fprintf_filtered (stream, ") ");
 484         }
 485 -      if (*elts >= options->print_max && i < F77_DIM_SIZE (nss))
 486 +      if (*elts >= options->print_max && i < upperbound)
 487         fprintf_filtered (stream, "...");
 488      }
 489    else
 490      {
 491 -      for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < options->print_max;
 492 +      for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;
 493            i++, (*elts)++)
 494         {
 495 -         val_print (TYPE_TARGET_TYPE (type),
 496 -                    valaddr,
 497 -                    embedded_offset + i * F77_DIM_OFFSET (ndimensions),
 498 -                    address, stream, recurse,
 499 -                    val, options, current_language);
 500 +         struct value *elt = value_subscript ((struct value *)val, i);
 501 +
 502 +         val_print (value_type (elt),
 503 +                    value_contents_for_printing (elt),
 504 +                    value_embedded_offset (elt),
 505 +                    value_address (elt), stream, recurse,
 506 +                    elt, options, current_language);
 507
 508 -         if (i != (F77_DIM_SIZE (nss) - 1))
 509 +         if (i != upperbound)
 510             fprintf_filtered (stream, ", ");
 511
 512           if ((*elts == options->print_max - 1)
 513 -             && (i != (F77_DIM_SIZE (nss) - 1)))
 514 +             && (i != upperbound))
 515             fprintf_filtered (stream, "...");
 516         }
 517      }
 518 @@ -225,12 +194,6 @@
 519  Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 520            ndimensions, MAX_FORTRAN_DIMS);
 521
 522 -  /* Since F77 arrays are stored column-major, we set up an
 523 -     offset table to get at the various row's elements.  The
 524 -     offset table contains entries for both offset and subarray size.  */
 525 -
 526 -  f77_create_arrayprint_offset_tbl (type, stream);
 527 -
 528    f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
 529                      address, stream, recurse, val, options, &elts);
 530  }
 531 @@ -375,12 +338,15 @@
 532        fprintf_filtered (stream, "( ");
 533        for (index = 0; index < TYPE_NFIELDS (type); index++)
 534          {
 535 -          int offset = TYPE_FIELD_BITPOS (type, index) / 8;
 536 +         struct value *field = value_field
 537 +           ((struct value *)original_value, index);
 538 +
 539 +          val_print (value_type (field),
 540 +                    value_contents_for_printing (field),
 541 +                    value_embedded_offset (field),
 542 +                    value_address (field), stream, recurse + 1,
 543 +                    field, options, current_language);
 544
 545 -          val_print (TYPE_FIELD_TYPE (type, index), valaddr,
 546 -                    embedded_offset + offset,
 547 -                    address, stream, recurse + 1,
 548 -                    original_value, options, current_language);
 549            if (index != TYPE_NFIELDS (type) - 1)
 550              fputs_filtered (", ", stream);
 551          }
 552 Index: gdb-7.10.50.20160106/gdb/gdbtypes.c
 553 ===================================================================
 554 --- gdb-7.10.50.20160106.orig/gdb/gdbtypes.c    2016-01-08 19:15:35.083582459 +0100
 555 +++ gdb-7.10.50.20160106/gdb/gdbtypes.c 2016-01-08 19:15:44.982637674 +0100
 556 @@ -836,7 +836,8 @@
 557  struct type *
 558  create_range_type (struct type *result_type, struct type *index_type,
 559                    const struct dynamic_prop *low_bound,
 560 -                  const struct dynamic_prop *high_bound)
 561 +                  const struct dynamic_prop *high_bound,
 562 +                  const struct dynamic_prop *stride)
 563  {
 564    if (result_type == NULL)
 565      result_type = alloc_type_copy (index_type);
 566 @@ -851,6 +852,7 @@
 567      TYPE_ZALLOC (result_type, sizeof (struct range_bounds));
 568    TYPE_RANGE_DATA (result_type)->low = *low_bound;
 569    TYPE_RANGE_DATA (result_type)->high = *high_bound;
 570 +  TYPE_RANGE_DATA (result_type)->stride = *stride;
 571
 572    if (low_bound->kind == PROP_CONST && low_bound->data.const_val >= 0)
 573      TYPE_UNSIGNED (result_type) = 1;
 574 @@ -879,7 +881,7 @@
 575  create_static_range_type (struct type *result_type, struct type *index_type,
 576                           LONGEST low_bound, LONGEST high_bound)
 577  {
 578 -  struct dynamic_prop low, high;
 579 +  struct dynamic_prop low, high, stride;
 580
 581    low.kind = PROP_CONST;
 582    low.data.const_val = low_bound;
 583 @@ -887,7 +889,11 @@
 584    high.kind = PROP_CONST;
 585    high.data.const_val = high_bound;
 586
 587 -  result_type = create_range_type (result_type, index_type, &low, &high);
 588 +  stride.kind = PROP_CONST;
 589 +  stride.data.const_val = 0;
 590 +
 591 +  result_type = create_range_type (result_type, index_type,
 592 +                                   &low, &high, &stride);
 593
 594    return result_type;
 595  }
 596 @@ -1084,16 +1090,21 @@
 597        && (!type_not_associated (result_type)
 598           && !type_not_allocated (result_type)))
 599      {
 600 -      LONGEST low_bound, high_bound;
 601 +      LONGEST low_bound, high_bound, byte_stride;
 602
 603        if (get_discrete_bounds (range_type, &low_bound, &high_bound) < 0)
 604         low_bound = high_bound = 0;
 605        element_type = check_typedef (element_type);
 606 +
 607 +      byte_stride = abs (TYPE_BYTE_STRIDE (range_type));
 608 +
 609        /* Be careful when setting the array length.  Ada arrays can be
 610          empty arrays with the high_bound being smaller than the low_bound.
 611          In such cases, the array length should be zero.  */
 612        if (high_bound < low_bound)
 613         TYPE_LENGTH (result_type) = 0;
 614 +      else if (byte_stride > 0)
 615 +       TYPE_LENGTH (result_type) = byte_stride * (high_bound - low_bound + 1);
 616        else if (bit_stride > 0)
 617         TYPE_LENGTH (result_type) =
 618           (bit_stride * (high_bound - low_bound + 1) + 7) / 8;
 619 @@ -1804,12 +1815,31 @@
 620  static int
 621  is_dynamic_type_internal (struct type *type, int top_level)
 622  {
 623 +  int index;
 624 +
 625 +  if (!type)
 626 +    return 0;
 627 +
 628    type = check_typedef (type);
 629
 630    /* We only want to recognize references at the outermost level.  */
 631    if (top_level && TYPE_CODE (type) == TYPE_CODE_REF)
 632      type = check_typedef (TYPE_TARGET_TYPE (type));
 633
 634 +  if (TYPE_ASSOCIATED_PROP (type))
 635 +    return 1;
 636 +
 637 +  if (TYPE_ALLOCATED_PROP (type))
 638 +    return 1;
 639 +
 640 +  /* Scan field types in the Fortran case for nested dynamic types.
 641 +     This will be done only for Fortran as in the C++ case an endless recursion
 642 +     can occur in the area of classes.  */
 643 +  if (current_language->la_language == language_fortran)
 644 +    for (index = 0; index < TYPE_NFIELDS (type); index++)
 645 +      if (is_dynamic_type (TYPE_FIELD_TYPE (type, index)))
 646 +        return 1;
 647 +
 648    /* Types that have a dynamic TYPE_DATA_LOCATION are considered
 649       dynamic, even if the type itself is statically defined.
 650       From a user's point of view, this may appear counter-intuitive;
 651 @@ -1844,11 +1874,19 @@
 652        {
 653         gdb_assert (TYPE_NFIELDS (type) == 1);
 654
 655 -       /* The array is dynamic if either the bounds are dynamic,
 656 -          or the elements it contains have a dynamic contents.  */
 657 +       /* The array is dynamic if either
 658 +     - the bounds are dynamic,
 659 +          - the elements it contains have a dynamic contents
 660 +     - a data_locaton attribute was found.  */
 661         if (is_dynamic_type_internal (TYPE_INDEX_TYPE (type), 0))
 662           return 1;
 663 -       return is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0);
 664 +       else if (TYPE_DATA_LOCATION (type) != NULL
 665 +                && (TYPE_DATA_LOCATION_KIND (type) == PROP_LOCEXPR
 666 +                    || TYPE_DATA_LOCATION_KIND (type) == PROP_LOCLIST))
 667 +    return 1;
 668 +  else
 669 +    return is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0);
 670 +       break;
 671        }
 672
 673      case TYPE_CODE_STRUCT:
 674 @@ -1861,6 +1899,18 @@
 675               && is_dynamic_type_internal (TYPE_FIELD_TYPE (type, i), 0))
 676             return 1;
 677        }
 678 +    case TYPE_CODE_PTR:
 679 +      {
 680 +        if (TYPE_TARGET_TYPE (type)
 681 +            && (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING
 682 +                || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY))
 683 +          return is_dynamic_type (check_typedef (TYPE_TARGET_TYPE (type)));
 684 +
 685 +        return 0;
 686 +        break;
 687 +      }
 688 +    default:
 689 +      return 0;
 690        break;
 691      }
 692
 693 @@ -1890,7 +1940,8 @@
 694    struct type *static_range_type, *static_target_type;
 695    const struct dynamic_prop *prop;
 696    const struct dwarf2_locexpr_baton *baton;
 697 -  struct dynamic_prop low_bound, high_bound;
 698 +  struct dynamic_prop low_bound, high_bound, stride;
 699 +  struct type *range_copy = copy_type (dyn_range_type);
 700
 701    gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE);
 702
 703 @@ -1922,12 +1973,19 @@
 704        high_bound.data.const_val = 0;
 705      }
 706
 707 +  prop = &TYPE_RANGE_DATA (dyn_range_type)->stride;
 708 +  if (dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
 709 +    {
 710 +      stride.kind = PROP_CONST;
 711 +      stride.data.const_val = value;
 712 +    }
 713 +
 714    static_target_type
 715 -    = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (dyn_range_type),
 716 +    = resolve_dynamic_type_internal (TYPE_TARGET_TYPE (range_copy),
 717                                      addr_stack, 0);
 718 -  static_range_type = create_range_type (copy_type (dyn_range_type),
 719 +  static_range_type = create_range_type (range_copy,
 720                                          static_target_type,
 721 -                                        &low_bound, &high_bound);
 722 +                                        &low_bound, &high_bound, &stride);
 723    TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1;
 724    return static_range_type;
 725  }
 726 @@ -1946,7 +2004,8 @@
 727    struct type *ary_dim;
 728    struct dynamic_prop *prop;
 729
 730 -  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
 731 +  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY
 732 +             || TYPE_CODE (type) == TYPE_CODE_STRING);
 733
 734    type = copy_type (type);
 735
 736 @@ -1971,13 +2030,18 @@
 737
 738    ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));
 739
 740 -  if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)
 741 +  if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY
 742 +                         || TYPE_CODE (ary_dim) == TYPE_CODE_STRING))
 743      elt_type = resolve_dynamic_array (ary_dim, addr_stack);
 744    else
 745      elt_type = TYPE_TARGET_TYPE (type);
 746
 747 -  return create_array_type_with_stride (type, elt_type, range_type,
 748 -                                        TYPE_FIELD_BITSIZE (type, 0));
 749 +  if (TYPE_CODE (type) == TYPE_CODE_STRING
 750 +      && TYPE_FIELD_BITSIZE (type, 0) == 0)
 751 +    return create_string_type (type, elt_type, range_type);
 752 +  else
 753 +    return create_array_type_with_stride (type, elt_type, range_type,
 754 +                                         TYPE_FIELD_BITSIZE (type, 0));
 755  }
 756
 757  /* Resolve dynamic bounds of members of the union TYPE to static
 758 Index: gdb-7.10.50.20160106/gdb/gdbtypes.h
 759 ===================================================================
 760 --- gdb-7.10.50.20160106.orig/gdb/gdbtypes.h    2016-01-08 19:15:35.085582471 +0100
 761 +++ gdb-7.10.50.20160106/gdb/gdbtypes.h 2016-01-08 19:15:44.983637680 +0100
 762 @@ -577,6 +577,10 @@
 763
 764    struct dynamic_prop high;
 765
 766 +  /* * Stride of range.  */
 767 +
 768 +  struct dynamic_prop stride;
 769 +
 770    /* True if HIGH range bound contains the number of elements in the
 771       subrange. This affects how the final hight bound is computed.  */
 772
 773 @@ -749,6 +753,18 @@
 774
 775    /* * Contains all dynamic type properties.  */
 776    struct dynamic_prop_list *dyn_prop_list;
 777 +
 778 +  /* Structure for DW_AT_allocated.
 779 +     The presence of this attribute indicates that the object of the type
 780 +     can be allocated/deallocated.  The value can be a dwarf expression,
 781 +     reference, or a constant.  */
 782 +  struct dynamic_prop *allocated;
 783 +
 784 +  /* Structure for DW_AT_associated.
 785 +     The presence of this attribute indicated that the object of the type
 786 +     can be associated.  The value can be a dwarf expression,
 787 +     reference, or a constant.  */
 788 +  struct dynamic_prop *associated;
 789  };
 790
 791  /* * A ``struct type'' describes a particular instance of a type, with
 792 @@ -1255,6 +1271,15 @@
 793    TYPE_RANGE_DATA(range_type)->high.kind
 794  #define TYPE_LOW_BOUND_KIND(range_type) \
 795    TYPE_RANGE_DATA(range_type)->low.kind
 796 +#define TYPE_BYTE_STRIDE(range_type) \
 797 +  TYPE_RANGE_DATA(range_type)->stride.data.const_val
 798 +#define TYPE_BYTE_STRIDE_BLOCK(range_type) \
 799 +  TYPE_RANGE_DATA(range_type)->stride.data.locexpr
 800 +#define TYPE_BYTE_STRIDE_LOCLIST(range_type) \
 801 +  TYPE_RANGE_DATA(range_type)->stride.data.loclist
 802 +#define TYPE_BYTE_STRIDE_KIND(range_type) \
 803 +  TYPE_RANGE_DATA(range_type)->stride.kind
 804 +
 805
 806  /* Property accessors for the type data location.  */
 807  #define TYPE_DATA_LOCATION(thistype) \
 808 @@ -1266,6 +1291,18 @@
 809  #define TYPE_DATA_LOCATION_KIND(thistype) \
 810    TYPE_DATA_LOCATION (thistype)->kind
 811
 812 +/* Allocated status of type object.  If set to non-zero it means the object
 813 +   is allocated. A zero value means it is not allocated.  */
 814 +#define TYPE_NOT_ALLOCATED(t)  (TYPE_ALLOCATED_PROP (t) \
 815 +  && TYPE_ALLOCATED_PROP (t)->kind == PROP_CONST \
 816 +  && !TYPE_ALLOCATED_PROP (t)->data.const_val)
 817 +
 818 +/* Associated status of type object.  If set to non-zero it means the object
 819 +   is associated. A zero value means it is not associated.  */
 820 +#define TYPE_NOT_ASSOCIATED(t)  (TYPE_ASSOCIATED_PROP (t) \
 821 +  && TYPE_ASSOCIATED_PROP (t)->kind == PROP_CONST \
 822 +  && !TYPE_ASSOCIATED_PROP (t)->data.const_val)
 823 +
 824  /* Property accessors for the type allocated/associated.  */
 825  #define TYPE_ALLOCATED_PROP(thistype) \
 826    get_dyn_prop (DYN_PROP_ALLOCATED, thistype)
 827 @@ -1289,6 +1326,9 @@
 828     TYPE_HIGH_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))
 829  #define TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED(arraytype) \
 830     TYPE_LOW_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))
 831 +#define TYPE_ARRAY_STRIDE_IS_UNDEFINED(arraytype) \
 832 +   (TYPE_BYTE_STRIDE(TYPE_INDEX_TYPE(arraytype)) == 0)
 833 +
 834
 835  #define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \
 836     (TYPE_HIGH_BOUND(TYPE_INDEX_TYPE((arraytype))))
 837 @@ -1775,6 +1815,7 @@
 838
 839  extern struct type *create_range_type (struct type *, struct type *,
 840                                        const struct dynamic_prop *,
 841 +                                      const struct dynamic_prop *,
 842                                        const struct dynamic_prop *);
 843
 844  extern struct type *create_array_type (struct type *, struct type *,
 845 Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.exp
 846 ===================================================================
 847 --- /dev/null   1970-01-01 00:00:00.000000000 +0000
 848 +++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.exp 2016-01-08 19:15:44.983637680 +0100
 849 @@ -0,0 +1,61 @@
 850 +# Copyright 2014 Free Software Foundation, Inc.
 851 +
 852 +# This program is free software; you can redistribute it and/or modify
 853 +# it under the terms of the GNU General Public License as published by
 854 +# the Free Software Foundation; either version 3 of the License, or
 855 +# (at your option) any later version.
 856 +#
 857 +# This program is distributed in the hope that it will be useful,
 858 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
 859 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 860 +# GNU General Public License for more details.
 861 +#
 862 +# You should have received a copy of the GNU General Public License
 863 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
 864 +
 865 +standard_testfile ".f90"
 866 +
 867 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
 868 +    {debug f90 quiet}] } {
 869 +    return -1
 870 +}
 871 +
 872 +if ![runto MAIN__] then {
 873 +    perror "couldn't run to breakpoint MAIN__"
 874 +    continue
 875 +}
 876 +
 877 +# Check VLA passed to first Fortran function.
 878 +gdb_breakpoint [gdb_get_line_number "func1-vla-passed"]
 879 +gdb_continue_to_breakpoint "func1-vla-passed"
 880 +gdb_test "print vla" " = \\( *\\( *22, *22, *22,\[()22, .\]*\\)" \
 881 +  "print vla (func1)"
 882 +gdb_test "ptype vla" "type = integer\\\(kind=4\\\) \\\(10,10\\\)" \
 883 +  "ptype vla (func1)"
 884 +
 885 +gdb_breakpoint [gdb_get_line_number "func1-vla-modified"]
 886 +gdb_continue_to_breakpoint "func1-vla-modified"
 887 +gdb_test "print vla(5,5)" " = 55" "print vla(5,5) (func1)"
 888 +gdb_test "print vla(7,7)" " = 77" "print vla(5,5) (func1)"
 889 +
 890 +# Check if the values are correct after returning from func1
 891 +gdb_breakpoint [gdb_get_line_number "func1-returned"]
 892 +gdb_continue_to_breakpoint "func1-returned"
 893 +gdb_test "print ret" " = .TRUE." "print ret after func1 returned"
 894 +
 895 +# Check VLA passed to second Fortran function
 896 +gdb_breakpoint [gdb_get_line_number "func2-vla-passed"]
 897 +gdb_continue_to_breakpoint "func2-vla-passed"
 898 +gdb_test "print vla" \
 899 +  " = \\\(44, 44, 44, 44, 44, 44, 44, 44, 44, 44\\\)" \
 900 +  "print vla (func2)"
 901 +gdb_test "ptype vla" "type = integer\\\(kind=4\\\) \\\(10\\\)" \
 902 +  "ptype vla (func2)"
 903 +
 904 +# Check if the returned VLA has the correct values and ptype.
 905 +gdb_breakpoint [gdb_get_line_number "func2-returned"]
 906 +gdb_continue_to_breakpoint "func2-returned"
 907 +gdb_test "print vla3" " = \\\(1, 2, 44, 4, 44, 44, 44, 8, 44, 44\\\)" \
 908 +  "print vla3 (after func2)"
 909 +gdb_test "ptype vla3" "type = integer\\\(kind=4\\\) \\\(10\\\)" \
 910 +  "ptype vla3 (after func2)"
 911 Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.f90
 912 ===================================================================
 913 --- /dev/null   1970-01-01 00:00:00.000000000 +0000
 914 +++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-func.f90 2016-01-08 19:15:44.983637680 +0100
 915 @@ -0,0 +1,71 @@
 916 +! Copyright 2014 Free Software Foundation, Inc.
 917 +!
 918 +! This program is free software; you can redistribute it and/or modify
 919 +! it under the terms of the GNU General Public License as published by
 920 +! the Free Software Foundation; either version 2 of the License, or
 921 +! (at your option) any later version.
 922 +!
 923 +! This program is distributed in the hope that it will be useful,
 924 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
 925 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 926 +! GNU General Public License for more details.
 927 +!
 928 +! You should have received a copy of the GNU General Public License
 929 +! along with this program; if not, write to the Free Software
 930 +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 931 +
 932 +logical function func1 (vla)
 933 +  implicit none
 934 +  integer, allocatable :: vla (:, :)
 935 +  func1 = allocated(vla)
 936 +  vla(5,5) = 55               ! func1-vla-passed
 937 +  vla(7,7) = 77
 938 +  return                      ! func1-vla-modified
 939 +end function func1
 940 +
 941 +function func2(vla)
 942 +  implicit none
 943 +  integer :: vla (:)
 944 +  integer :: func2(size(vla))
 945 +  integer :: k
 946 +
 947 +  vla(1) = 1                    ! func2-vla-passed
 948 +  vla(2) = 2
 949 +  vla(4) = 4
 950 +  vla(8) = 8
 951 +
 952 +  func2 = vla
 953 +end function func2
 954 +
 955 +program vla_func
 956 +  implicit none
 957 +  interface
 958 +    logical function func1 (vla)
 959 +      integer :: vla (:, :)
 960 +    end function
 961 +  end interface
 962 +  interface
 963 +    function func2 (vla)
 964 +      integer :: vla (:)
 965 +      integer func2(size(vla))
 966 +    end function
 967 +  end interface
 968 +
 969 +  logical :: ret
 970 +  integer, allocatable :: vla1 (:, :)
 971 +  integer, allocatable :: vla2 (:)
 972 +  integer, allocatable :: vla3 (:)
 973 +
 974 +  ret = .FALSE.
 975 +
 976 +  allocate (vla1 (10,10))
 977 +  vla1(:,:) = 22
 978 +
 979 +  allocate (vla2 (10))
 980 +  vla2(:) = 44
 981 +
 982 +  ret = func1(vla1)
 983 +  vla3 = func2(vla2)          ! func1-returned
 984 +
 985 +  ret = .TRUE.                ! func2-returned
 986 +end program vla_func
 987 Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-stride.exp
 988 ===================================================================
 989 --- /dev/null   1970-01-01 00:00:00.000000000 +0000
 990 +++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-stride.exp       2016-01-08 19:15:44.984637686 +0100
 991 @@ -0,0 +1,44 @@
 992 +# Copyright 2014 Free Software Foundation, Inc.
 993 +
 994 +# This program is free software; you can redistribute it and/or modify
 995 +# it under the terms of the GNU General Public License as published by
 996 +# the Free Software Foundation; either version 3 of the License, or
 997 +# (at your option) any later version.
 998 +#
 999 +# This program is distributed in the hope that it will be useful,
1000 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1001 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1002 +# GNU General Public License for more details.
1003 +#
1004 +# You should have received a copy of the GNU General Public License
1005 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1006 +
1007 +standard_testfile ".f90"
1008 +
1009 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1010 +    {debug f90 quiet}] } {
1011 +    return -1
1012 +}
1013 +
1014 +if ![runto MAIN__] then {
1015 +    perror "couldn't run to breakpoint MAIN__"
1016 +    continue
1017 +}
1018 +
1019 +gdb_breakpoint [gdb_get_line_number "re-reverse-elements"]
1020 +gdb_continue_to_breakpoint "re-reverse-elements"
1021 +gdb_test "print pvla" " = \\\(1, 2, 3, 4, 5, 6, 7, 8, 9, 10\\\)" \
1022 +  "print re-reverse-elements"
1023 +gdb_test "print pvla(1)" " = 1" "print first re-reverse-element"
1024 +gdb_test "print pvla(10)" " = 10" "print last re-reverse-element"
1025 +
1026 +gdb_breakpoint [gdb_get_line_number "odd-elements"]
1027 +gdb_continue_to_breakpoint "odd-elements"
1028 +gdb_test "print pvla" " = \\\(1, 3, 5, 7, 9\\\)" "print odd-elements"
1029 +gdb_test "print pvla(1)" " = 1" "print first odd-element"
1030 +gdb_test "print pvla(5)" " = 9" "print last odd-element"
1031 +
1032 +gdb_breakpoint [gdb_get_line_number "single-element"]
1033 +gdb_continue_to_breakpoint "single-element"
1034 +gdb_test "print pvla" " = \\\(5\\\)" "print single-element"
1035 +gdb_test "print pvla(1)" " = 5" "print one single-element"
1036 Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-stride.f90
1037 ===================================================================
1038 --- /dev/null   1970-01-01 00:00:00.000000000 +0000
1039 +++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-stride.f90       2016-01-08 19:15:44.984637686 +0100
1040 @@ -0,0 +1,30 @@
1041 +! Copyright 2014 Free Software Foundation, Inc.
1042 +!
1043 +! This program is free software; you can redistribute it and/or modify
1044 +! it under the terms of the GNU General Public License as published by
1045 +! the Free Software Foundation; either version 2 of the License, or
1046 +! (at your option) any later version.
1047 +!
1048 +! This program is distributed in the hope that it will be useful,
1049 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
1050 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1051 +! GNU General Public License for more details.
1052 +!
1053 +! You should have received a copy of the GNU General Public License
1054 +! along with this program; if not, write to the Free Software
1055 +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
1056 +
1057 +program vla_stride
1058 +  integer, target, allocatable :: vla (:)
1059 +  integer, pointer :: pvla (:)
1060 +
1061 +  allocate(vla(10))
1062 +  vla = (/ (I, I = 1,10) /)
1063 +
1064 +  pvla => vla(10:1:-1)
1065 +  pvla => pvla(10:1:-1)
1066 +  pvla => vla(1:10:2)   ! re-reverse-elements
1067 +  pvla => vla(5:4:-2)   ! odd-elements
1068 +
1069 +  pvla => null()        ! single-element
1070 +end program vla_stride
1071 Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-strings.exp
1072 ===================================================================
1073 --- /dev/null   1970-01-01 00:00:00.000000000 +0000
1074 +++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-strings.exp      2016-01-08 19:15:44.984637686 +0100
1075 @@ -0,0 +1,101 @@
1076 +# Copyright 2014 Free Software Foundation, Inc.
1077 +
1078 +# This program is free software; you can redistribute it and/or modify
1079 +# it under the terms of the GNU General Public License as published by
1080 +# the Free Software Foundation; either version 3 of the License, or
1081 +# (at your option) any later version.
1082 +#
1083 +# This program is distributed in the hope that it will be useful,
1084 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1085 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1086 +# GNU General Public License for more details.
1087 +#
1088 +# You should have received a copy of the GNU General Public License
1089 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1090 +
1091 +standard_testfile ".f90"
1092 +
1093 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1094 +    {debug f90 quiet}] } {
1095 +    return -1
1096 +}
1097 +
1098 +# check that all fortran standard datatypes will be
1099 +# handled correctly when using as VLA's
1100 +
1101 +if ![runto MAIN__] then {
1102 +    perror "couldn't run to breakpoint MAIN__"
1103 +    continue
1104 +}
1105 +
1106 +gdb_breakpoint [gdb_get_line_number "var_char-allocated-1"]
1107 +gdb_continue_to_breakpoint "var_char-allocated-1"
1108 +gdb_test "print var_char" \
1109 +  " = \\(PTR TO -> \\( character\\*10 \\)\\) ${hex}" \
1110 +  "print var_char after allocated first time"
1111 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*10 \\)" \
1112 +  "whatis var_char first time"
1113 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*10 \\)" \
1114 +  "ptype var_char first time"
1115 +gdb_test "next" "\\d+.*var_char = 'foo'.*" \
1116 +  "next to allocation status of var_char"
1117 +gdb_test "print l" " = .TRUE." "print allocation status first time"
1118 +
1119 +gdb_breakpoint [gdb_get_line_number "var_char-filled-1"]
1120 +gdb_continue_to_breakpoint "var_char-filled-1"
1121 +gdb_test "print var_char" \
1122 +  " = \\(PTR TO -> \\( character\\*3 \\)\\) ${hex}" \
1123 +  "print var_char after filled first time"
1124 +gdb_test "print *var_char" " = 'foo'" \
1125 +  "print *var_char after filled first time"
1126 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*3 \\)" \
1127 +  "whatis var_char after filled first time"
1128 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*3 \\)" \
1129 +  "ptype var_char after filled first time"
1130 +gdb_test "print var_char(1)" " = 102 'f'" "print var_char(1)"
1131 +gdb_test "print var_char(3)" " = 111 'o'" "print var_char(3)"
1132 +
1133 +gdb_breakpoint [gdb_get_line_number "var_char-filled-2"]
1134 +gdb_continue_to_breakpoint "var_char-filled-2"
1135 +gdb_test "print var_char" \
1136 +  " = \\(PTR TO -> \\( character\\*6 \\)\\) ${hex}" \
1137 +  "print var_char after allocated second time"
1138 +gdb_test "print *var_char" " = 'foobar'" \
1139 +  "print *var_char after allocated second time"
1140 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*6 \\)" \
1141 +  "whatis var_char second time"
1142 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*6 \\)" \
1143 +  "ptype var_char second time"
1144 +
1145 +gdb_breakpoint [gdb_get_line_number "var_char-empty"]
1146 +gdb_continue_to_breakpoint "var_char-empty"
1147 +gdb_test "print var_char" \
1148 +  " = \\(PTR TO -> \\( character\\*0 \\)\\) ${hex}" \
1149 +  "print var_char after set empty"
1150 +gdb_test "print *var_char" " = \"\"" "print *var_char after set empty"
1151 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*0 \\)" \
1152 +  "whatis var_char after set empty"
1153 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*0 \\)" \
1154 +  "ptype var_char after set empty"
1155 +
1156 +gdb_breakpoint [gdb_get_line_number "var_char-allocated-3"]
1157 +gdb_continue_to_breakpoint "var_char-allocated-3"
1158 +gdb_test "print var_char" \
1159 +  " = \\(PTR TO -> \\( character\\*21 \\)\\) ${hex}" \
1160 +  "print var_char after allocated third time"
1161 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*21 \\)" \
1162 +  "whatis var_char after allocated third time"
1163 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*21 \\)" \
1164 +  "ptype var_char after allocated third time"
1165 +
1166 +gdb_breakpoint [gdb_get_line_number "var_char_p-associated"]
1167 +gdb_continue_to_breakpoint "var_char_p-associated"
1168 +gdb_test "print var_char_p" \
1169 +  " = \\(PTR TO -> \\( character\\*7 \\)\\) ${hex}" \
1170 +  "print var_char_p after associated"
1171 +gdb_test "print *var_char_p" " = 'johndoe'" \
1172 +  "print *var_char_ after associated"
1173 +gdb_test "whatis var_char_p" "type = PTR TO -> \\( character\\*7 \\)" \
1174 +  "whatis var_char_p after associated"
1175 +gdb_test "ptype var_char_p" "type = PTR TO -> \\( character\\*7 \\)" \
1176 +  "ptype var_char_p after associated"
1177 Index: gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-strings.f90
1178 ===================================================================
1179 --- /dev/null   1970-01-01 00:00:00.000000000 +0000
1180 +++ gdb-7.10.50.20160106/gdb/testsuite/gdb.fortran/vla-strings.f90      2016-01-08 19:15:44.984637686 +0100
1181 @@ -0,0 +1,40 @@
1182 +! Copyright 2014 Free Software Foundation, Inc.
1183 +!
1184 +! This program is free software; you can redistribute it and/or modify
1185 +! it under the terms of the GNU General Public License as published by
1186 +! the Free Software Foundation; either version 2 of the License, or
1187 +! (at your option) any later version.
1188 +!
1189 +! This program is distributed in the hope that it will be useful,
1190 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
1191 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1192 +! GNU General Public License for more details.
1193 +!
1194 +! You should have received a copy of the GNU General Public License
1195 +! along with this program; if not, write to the Free Software
1196 +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
1197 +
1198 +program vla_strings
1199 +  character(len=:), target, allocatable   :: var_char
1200 +  character(len=:), pointer               :: var_char_p
1201 +  logical                                 :: l
1202 +
1203 +  allocate(character(len=10) :: var_char)
1204 +  l = allocated(var_char)                 ! var_char-allocated-1
1205 +  var_char = 'foo'
1206 +  deallocate(var_char)                    ! var_char-filled-1
1207 +  l = allocated(var_char)                 ! var_char-deallocated
1208 +  allocate(character(len=42) :: var_char)
1209 +  l = allocated(var_char)
1210 +  var_char = 'foobar'
1211 +  var_char = ''                           ! var_char-filled-2
1212 +  var_char = 'bar'                        ! var_char-empty
1213 +  deallocate(var_char)
1214 +  allocate(character(len=21) :: var_char)
1215 +  l = allocated(var_char)                 ! var_char-allocated-3
1216 +  var_char = 'johndoe'
1217 +  var_char_p => var_char
1218 +  l = associated(var_char_p)              ! var_char_p-associated
1219 +  var_char_p => null()
1220 +  l = associated(var_char_p)              ! var_char_p-not-associated
1221 +end program vla_strings
1222 Index: gdb-7.10.50.20160106/gdb/typeprint.c
1223 ===================================================================
1224 --- gdb-7.10.50.20160106.orig/gdb/typeprint.c   2016-01-08 19:15:35.086582476 +0100
1225 +++ gdb-7.10.50.20160106/gdb/typeprint.c        2016-01-08 19:15:44.984637686 +0100
1226 @@ -460,6 +460,13 @@
1227
1228    type = value_type (val);
1229
1230 +  if (TYPE_CODE (type) == TYPE_CODE_PTR)
1231 +    if (is_dynamic_type (TYPE_TARGET_TYPE (type)))
1232 +      {
1233 +       val = value_addr (value_ind (val));
1234 +       type = value_type (val);
1235 +      }
1236 +
1237    get_user_print_options (&opts);
1238    if (opts.objectprint)
1239      {
1240 Index: gdb-7.10.50.20160106/gdb/valarith.c
1241 ===================================================================
1242 --- gdb-7.10.50.20160106.orig/gdb/valarith.c    2016-01-08 19:15:35.087582482 +0100
1243 +++ gdb-7.10.50.20160106/gdb/valarith.c 2016-01-08 19:15:44.985637691 +0100
1244 @@ -193,9 +193,21 @@
1245    struct type *array_type = check_typedef (value_type (array));
1246    struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (array_type));
1247    unsigned int elt_size = type_length_units (elt_type);
1248 -  unsigned int elt_offs = elt_size * longest_to_int (index - lowerbound);
1249 +  unsigned int elt_offs = longest_to_int (index - lowerbound);
1250 +  LONGEST elt_stride = TYPE_BYTE_STRIDE (TYPE_INDEX_TYPE (array_type));
1251    struct value *v;
1252
1253 +  if (elt_stride > 0)
1254 +    elt_offs *= elt_stride;
1255 +  else if (elt_stride < 0)
1256 +    {
1257 +      int offs = (elt_offs + 1) * elt_stride;
1258 +
1259 +      elt_offs = TYPE_LENGTH (array_type) + offs;
1260 +    }
1261 +  else
1262 +    elt_offs *= elt_size;
1263 +
1264    if (index < lowerbound || (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)
1265                              && elt_offs >= type_length_units (array_type)))
1266      {
1267 Index: gdb-7.10.50.20160106/gdb/valprint.c
1268 ===================================================================
1269 --- gdb-7.10.50.20160106.orig/gdb/valprint.c    2016-01-08 19:15:35.088582487 +0100
1270 +++ gdb-7.10.50.20160106/gdb/valprint.c 2016-01-08 19:15:44.986637697 +0100
1271 @@ -316,6 +316,18 @@
1272        return 0;
1273      }
1274
1275 +  if (TYPE_NOT_ASSOCIATED (type))
1276 +    {
1277 +      val_print_not_associated (stream);
1278 +      return 0;
1279 +    }
1280 +
1281 +  if (TYPE_NOT_ALLOCATED (type))
1282 +    {
1283 +      val_print_not_allocated (stream);
1284 +      return 0;
1285 +    }
1286 +
1287    if (TYPE_CODE (type) != TYPE_CODE_UNION
1288        && TYPE_CODE (type) != TYPE_CODE_STRUCT
1289        && TYPE_CODE (type) != TYPE_CODE_ARRAY)
1290 @@ -1025,12 +1037,16 @@
1291  value_check_printable (struct value *val, struct ui_file *stream,
1292                        const struct value_print_options *options)
1293  {
1294 +  const struct type *type;
1295 +
1296    if (val == 0)
1297      {
1298        fprintf_filtered (stream, _("<address of value unknown>"));
1299        return 0;
1300      }
1301
1302 +  type = value_type (val);
1303 +
1304    if (value_entirely_optimized_out (val))
1305      {
1306        if (options->summary && !val_print_scalar_type_p (value_type (val)))
1307 @@ -1066,6 +1082,18 @@
1308      {
1309        val_print_not_allocated (stream);
1310        return 0;
1311 +    }
1312 +
1313 +  if (TYPE_NOT_ASSOCIATED (type))
1314 +    {
1315 +      val_print_not_associated (stream);
1316 +      return 0;
1317 +    }
1318 +
1319 +  if (TYPE_NOT_ALLOCATED (type))
1320 +    {
1321 +      val_print_not_allocated (stream);
1322 +      return 0;
1323      }
1324
1325    return 1;
1326 Index: gdb-7.10.50.20160106/gdb/valprint.h
1327 ===================================================================
1328 --- gdb-7.10.50.20160106.orig/gdb/valprint.h    2016-01-08 19:15:35.088582487 +0100
1329 +++ gdb-7.10.50.20160106/gdb/valprint.h 2016-01-08 19:15:44.986637697 +0100
1330 @@ -232,4 +232,8 @@
1331                                         struct format_data *fmtp);
1332  extern void print_value (struct value *val, const struct format_data *fmtp);
1333
1334 +extern void val_print_not_allocated (struct ui_file *stream);
1335 +
1336 +extern void val_print_not_associated (struct ui_file *stream);
1337 +
1338  #endif
1339 Index: gdb-7.10.50.20160106/gdb/value.c
1340 ===================================================================
1341 --- gdb-7.10.50.20160106.orig/gdb/value.c       2016-01-08 19:15:35.090582499 +0100
1342 +++ gdb-7.10.50.20160106/gdb/value.c    2016-01-08 19:15:44.987637702 +0100
1343 @@ -40,6 +40,7 @@
1344  #include "tracepoint.h"
1345  #include "cp-abi.h"
1346  #include "user-regs.h"
1347 +#include "dwarf2loc.h"
1348
1349  /* Prototypes for exported functions.  */
1350
1351 @@ -1788,6 +1789,25 @@
1352        if (funcs->copy_closure)
1353          component->location.computed.closure = funcs->copy_closure (whole);
1354      }
1355 +
1356 +  /* For dynamic types compute the address of the component value location in
1357 +     sub range types based on the location of the sub range type, if not being
1358 +     an internal GDB variable or parts of it.  */
1359 +  if (VALUE_LVAL (component) != lval_internalvar
1360 +      && VALUE_LVAL (component) != lval_internalvar_component)
1361 +    {
1362 +      CORE_ADDR addr;
1363 +      struct type *type = value_type (whole);
1364 +
1365 +      addr = value_raw_address (component);
1366 +
1367 +      if (TYPE_DATA_LOCATION (type)
1368 +          && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
1369 +        {
1370 +          addr = TYPE_DATA_LOCATION_ADDR (type);
1371 +          set_value_address (component, addr);
1372 +        }
1373 +    }
1374  }
1375
1376  \f
1377 @@ -3095,13 +3115,22 @@
1378         v = allocate_value_lazy (type);
1379        else
1380         {
1381 -         v = allocate_value (type);
1382 -         value_contents_copy_raw (v, value_embedded_offset (v),
1383 -                                  arg1, value_embedded_offset (arg1) + offset,
1384 -                                  type_length_units (type));
1385 +         if (TYPE_DATA_LOCATION (type)
1386 +             && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
1387 +           v = value_at_lazy (type, value_address (arg1) + offset);
1388 +         else
1389 +           {
1390 +             v = allocate_value (type);
1391 +             value_contents_copy_raw (v, value_embedded_offset (v),
1392 +                                      arg1, value_embedded_offset (arg1) + offset,
1393 +                                      type_length_units (type));
1394 +           }
1395         }
1396 -      v->offset = (value_offset (arg1) + offset
1397 -                  + value_embedded_offset (arg1));
1398 +
1399 +      if (!TYPE_DATA_LOCATION (type)
1400 +          || !TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
1401 +       v->offset = (value_offset (arg1) + offset
1402 +                    + value_embedded_offset (arg1));
1403      }
1404    set_value_component_location (v, arg1);
1405    VALUE_REGNUM (v) = VALUE_REGNUM (arg1);
1406 @@ -3689,7 +3718,8 @@
1407                               struct value *original_value)
1408  {
1409    /* Re-adjust type.  */
1410 -  deprecated_set_value_type (value, TYPE_TARGET_TYPE (original_type));
1411 +  if (!is_dynamic_type (TYPE_TARGET_TYPE (original_type)))
1412 +    deprecated_set_value_type (value, TYPE_TARGET_TYPE (original_type));
1413
1414    /* Add embedding info.  */
1415    set_value_enclosing_type (value, enc_type);
1416 @@ -3706,6 +3736,12 @@
1417    struct value *retval;
1418    struct type *enc_type;
1419
1420 +  if (current_language->la_language != language_fortran
1421 +      && TYPE_DATA_LOCATION (value_type_arg_tmp) != NULL
1422 +      && TYPE_DATA_LOCATION_KIND (value_type_arg_tmp) == PROP_CONST)
1423 +    arg = value_at_lazy (value_type_arg_tmp,
1424 +                         TYPE_DATA_LOCATION_ADDR (value_type_arg_tmp));
1425 +
1426    retval = coerce_ref_if_computed (arg);
1427    if (retval)
1428      return retval;
1429 @@ -3834,8 +3870,14 @@
1430      }
1431    else if (VALUE_LVAL (val) == lval_memory)
1432      {
1433 -      CORE_ADDR addr = value_address (val);
1434        struct type *type = check_typedef (value_enclosing_type (val));
1435 +      CORE_ADDR addr;
1436 +
1437 +      if (TYPE_DATA_LOCATION (type) != NULL
1438 +         && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
1439 +       addr = TYPE_DATA_LOCATION_ADDR (type);
1440 +      else
1441 +       addr = value_address (val);
1442
1443        if (TYPE_LENGTH (type))
1444         read_value_memory (val, 0, value_stack (val),
1445 Index: gdb-7.10.50.20160106/gdb/dwarf2loc.c
1446 ===================================================================
1447 --- gdb-7.10.50.20160106.orig/gdb/dwarf2loc.c   2016-01-08 19:15:35.091582504 +0100
1448 +++ gdb-7.10.50.20160106/gdb/dwarf2loc.c        2016-01-08 19:15:44.988637708 +0100
1449 @@ -2368,6 +2368,11 @@
1450             address = value_as_address (value_from_pointer (ptr_type, address));
1451
1452             do_cleanups (value_chain);
1453 +
1454 +           /* Select right frame to correctly evaluate VLA's during a backtrace.  */
1455 +           if (is_dynamic_type (type))
1456 +             select_frame (frame);
1457 +
1458             retval = value_at_lazy (type, address + byte_offset);
1459             if (in_stack_memory)
1460               set_value_stack (retval, 1);
1461 @@ -2660,6 +2665,19 @@
1462                              data, data + size, per_cu);
1463  }
1464
1465 +/* See dwarf2loc.h.  */
1466 +
1467 +int
1468 +dwarf2_address_data_valid (const struct type *type)
1469 +{
1470 +  if (TYPE_NOT_ASSOCIATED (type))
1471 +    return 0;
1472 +
1473 +  if (TYPE_NOT_ALLOCATED (type))
1474 +    return 0;
1475 +
1476 +  return 1;
1477 +}
1478  \f
1479  /* Helper functions and baton for dwarf2_loc_desc_needs_frame.  */
1480