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 diff --git a/gdb/NEWS b/gdb/NEWS
  10 index d9a19ae..e6885d2 100644
  11 ### a/gdb/NEWS
  12 ### b/gdb/NEWS
  13 @@ -3,6 +3,9 @@
  14
  15  *** Changes since GDB 7.8
  16
  17 +* Fortran dynamic array support: It allows the user to evaluate
  18 +  dynamic arrays like an ordinary static array.
  19 +
  20  *** Changes in GDB 7.8
  21
  22  * New command line options
  23 diff --git a/gdb/c-valprint.c b/gdb/c-valprint.c
  24 index f4694b0..8c45276 100644
  25 --- a/gdb/c-valprint.c
  26 +++ b/gdb/c-valprint.c
  27 @@ -538,7 +538,16 @@ c_value_print (struct value *val, struct ui_file *stream,
  28         {
  29           /* normal case */
  30           fprintf_filtered (stream, "(");
  31 -         type_print (value_type (val), "", stream, -1);
  32 +         if (is_dynamic_type (TYPE_TARGET_TYPE (type)))
  33 +           {
  34 +             struct value *v;
  35 +
  36 +             v = value_ind (val);
  37 +             v = value_addr (v);
  38 +             type_print (value_type (v), "", stream, -1);
  39 +           }
  40 +         else
  41 +           type_print (value_type (val), "", stream, -1);
  42           fprintf_filtered (stream, ") ");
  43         }
  44      }
  45 diff --git a/gdb/dwarf2expr.c b/gdb/dwarf2expr.c
  46 index 36c9f66..274ba62 100644
  47 --- a/gdb/dwarf2expr.c
  48 +++ b/gdb/dwarf2expr.c
  49 @@ -1478,6 +1478,12 @@ execute_stack_op (struct dwarf_expr_context *ctx,
  50           }
  51           break;
  52
  53 +        case DW_OP_push_object_address:
  54 +         /* Return the address of the object we are currently observing.  */
  55 +         result = (ctx->funcs->get_object_address) (ctx->baton);
  56 +         result_val = value_from_ulongest (address_type, result);
  57 +         break;
  58 +
  59         default:
  60           error (_("Unhandled dwarf expression opcode 0x%x"), op);
  61         }
  62 diff --git a/gdb/dwarf2expr.h b/gdb/dwarf2expr.h
  63 index 39dadf3..8cebbe8 100644
  64 --- a/gdb/dwarf2expr.h
  65 +++ b/gdb/dwarf2expr.h
  66 @@ -84,12 +84,8 @@ struct dwarf_expr_context_funcs
  67       This can throw an exception if the index is out of range.  */
  68    CORE_ADDR (*get_addr_index) (void *baton, unsigned int index);
  69
  70 -#if 0
  71 -  /* Not yet implemented.  */
  72 -
  73    /* Return the `object address' for DW_OP_push_object_address.  */
  74    CORE_ADDR (*get_object_address) (void *baton);
  75 -#endif
  76  };
  77
  78  /* The location of a value.  */
  79 diff --git a/gdb/dwarf2loc.c b/gdb/dwarf2loc.c
  80 index fcab9b9..a624dac 100644
  81 --- a/gdb/dwarf2loc.c
  82 +++ b/gdb/dwarf2loc.c
  83 @@ -306,6 +306,7 @@ struct dwarf_expr_baton
  84  {
  85    struct frame_info *frame;
  86    struct dwarf2_per_cu_data *per_cu;
  87 +  CORE_ADDR obj_address;
  88  };
  89
  90  /* Helper functions for dwarf2_evaluate_loc_desc.  */
  91 @@ -1209,6 +1210,7 @@ dwarf_expr_push_dwarf_reg_entry_value (struct dwarf_expr_context *ctx,
  92
  93    baton_local.frame = caller_frame;
  94    baton_local.per_cu = caller_per_cu;
  95 +  baton_local.obj_address = 0;
  96
  97    saved_ctx.gdbarch = ctx->gdbarch;
  98    saved_ctx.addr_size = ctx->addr_size;
  99 @@ -1238,6 +1240,22 @@ dwarf_expr_get_addr_index (void *baton, unsigned int index)
 100    return dwarf2_read_addr_index (debaton->per_cu, index);
 101  }
 102
 103 +/* Callback function for get_object_address. Return the address of the VLA
 104 +   object.  */
 105 +
 106 +static CORE_ADDR
 107 +dwarf_expr_get_obj_addr (void *baton)
 108 +{
 109 +  struct dwarf_expr_baton *debaton = baton;
 110 +
 111 +  gdb_assert (debaton != NULL);
 112 +
 113 +  if (debaton->obj_address == 0)
 114 +    error (_("Location address is not set."));
 115 +
 116 +  return debaton->obj_address;
 117 +}
 118 +
 119  /* VALUE must be of type lval_computed with entry_data_value_funcs.  Perform
 120     the indirect method on it, that is use its stored target value, the sole
 121     purpose of entry_data_value_funcs..  */
 122 @@ -2202,7 +2220,8 @@ static const struct dwarf_expr_context_funcs dwarf_expr_ctx_funcs =
 123    dwarf_expr_dwarf_call,
 124    dwarf_expr_get_base_type,
 125    dwarf_expr_push_dwarf_reg_entry_value,
 126 -  dwarf_expr_get_addr_index
 127 +  dwarf_expr_get_addr_index,
 128 +  dwarf_expr_get_obj_addr
 129  };
 130
 131  /* Evaluate a location description, starting at DATA and with length
 132 @@ -2231,6 +2250,7 @@ dwarf2_evaluate_loc_desc_full (struct type *type, struct frame_info *frame,
 133
 134    baton.frame = frame;
 135    baton.per_cu = per_cu;
 136 +  baton.obj_address = 0;
 137
 138    ctx = new_dwarf_expr_context ();
 139    old_chain = make_cleanup_free_dwarf_expr_context (ctx);
 140 @@ -2326,6 +2346,11 @@ dwarf2_evaluate_loc_desc_full (struct type *type, struct frame_info *frame,
 141             int in_stack_memory = dwarf_expr_fetch_in_stack_memory (ctx, 0);
 142
 143             do_cleanups (value_chain);
 144 +
 145 +           /* Select right frame to correctly evaluate VLA's during a backtrace.  */
 146 +           if (is_dynamic_type (type))
 147 +             select_frame (frame);
 148 +
 149             retval = value_at_lazy (type, address + byte_offset);
 150             if (in_stack_memory)
 151               set_value_stack (retval, 1);
 152 @@ -2436,6 +2461,7 @@ dwarf2_evaluate_loc_desc (struct type *type, struct frame_info *frame,
 153
 154  static int
 155  dwarf2_locexpr_baton_eval (const struct dwarf2_locexpr_baton *dlbaton,
 156 +         CORE_ADDR addr,
 157                            CORE_ADDR *valp)
 158  {
 159    struct dwarf_expr_context *ctx;
 160 @@ -2451,6 +2477,7 @@ dwarf2_locexpr_baton_eval (const struct dwarf2_locexpr_baton *dlbaton,
 161
 162    baton.frame = get_selected_frame (NULL);
 163    baton.per_cu = dlbaton->per_cu;
 164 +  baton.obj_address = addr;
 165
 166    objfile = dwarf2_per_cu_objfile (dlbaton->per_cu);
 167
 168 @@ -2491,7 +2518,8 @@ dwarf2_locexpr_baton_eval (const struct dwarf2_locexpr_baton *dlbaton,
 169  /* See dwarf2loc.h.  */
 170
 171  int
 172 -dwarf2_evaluate_property (const struct dynamic_prop *prop, CORE_ADDR *value)
 173 +dwarf2_evaluate_property (const struct dynamic_prop *prop, CORE_ADDR address,
 174 +        CORE_ADDR *value)
 175  {
 176    if (prop == NULL)
 177      return 0;
 178 @@ -2502,7 +2530,7 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop, CORE_ADDR *value)
 179        {
 180         const struct dwarf2_property_baton *baton = prop->data.baton;
 181
 182 -       if (dwarf2_locexpr_baton_eval (&baton->locexpr, value))
 183 +       if (dwarf2_locexpr_baton_eval (&baton->locexpr, address, value))
 184           {
 185             if (baton->referenced_type)
 186               {
 187 @@ -2546,6 +2574,20 @@ dwarf2_evaluate_property (const struct dynamic_prop *prop, CORE_ADDR *value)
 188    return 0;
 189  }
 190
 191 +/* See dwarf2loc.h.  */
 192 +
 193 +int
 194 +dwarf2_address_data_valid (const struct type *type)
 195 +{
 196 +  if (TYPE_NOT_ASSOCIATED (type))
 197 +    return 0;
 198 +
 199 +  if (TYPE_NOT_ALLOCATED (type))
 200 +    return 0;
 201 +
 202 +  return 1;
 203 +}
 204 +
 205  \f
 206  /* Helper functions and baton for dwarf2_loc_desc_needs_frame.  */
 207
 208 @@ -2653,6 +2695,15 @@ needs_get_addr_index (void *baton, unsigned int index)
 209    return 1;
 210  }
 211
 212 +/* DW_OP_push_object_address has a frame already passed through.  */
 213 +
 214 +static CORE_ADDR
 215 +needs_get_obj_addr (void *baton)
 216 +{
 217 +  /* Nothing to do.  */
 218 +  return 1;
 219 +}
 220 +
 221  /* Virtual method table for dwarf2_loc_desc_needs_frame below.  */
 222
 223  static const struct dwarf_expr_context_funcs needs_frame_ctx_funcs =
 224 @@ -2667,7 +2718,8 @@ static const struct dwarf_expr_context_funcs needs_frame_ctx_funcs =
 225    needs_frame_dwarf_call,
 226    NULL,                                /* get_base_type */
 227    needs_dwarf_reg_entry_value,
 228 -  needs_get_addr_index
 229 +  needs_get_addr_index,
 230 +  needs_get_obj_addr
 231  };
 232
 233  /* Return non-zero iff the location expression at DATA (length SIZE)
 234 @@ -3316,6 +3368,10 @@ dwarf2_compile_expr_to_ax (struct agent_expr *expr, struct axs_value *loc,
 235           unimplemented (op);
 236           break;
 237
 238 +  case DW_OP_push_object_address:
 239 +    unimplemented (op);
 240 +    break;
 241 +
 242         case DW_OP_skip:
 243           offset = extract_signed_integer (op_ptr, 2, byte_order);
 244           op_ptr += 2;
 245 diff --git a/gdb/dwarf2loc.h b/gdb/dwarf2loc.h
 246 index 8ad5fa9..fb65c5c 100644
 247 --- a/gdb/dwarf2loc.h
 248 +++ b/gdb/dwarf2loc.h
 249 @@ -96,11 +96,18 @@ struct value *dwarf2_evaluate_loc_desc (struct type *type,
 250     into VALUE, otherwise returns 0.  */
 251
 252  int dwarf2_evaluate_property (const struct dynamic_prop *prop,
 253 +                             CORE_ADDR address,
 254                               CORE_ADDR *value);
 255
 256  CORE_ADDR dwarf2_read_addr_index (struct dwarf2_per_cu_data *per_cu,
 257                                   unsigned int addr_index);
 258
 259 +/* Checks if a dwarf location definition is valid.
 260 +   Returns 1 if valid; 0 otherwise.  */
 261 +
 262 +extern int dwarf2_address_data_valid (const struct type *type);
 263 +
 264 +
 265  /* The symbol location baton types used by the DWARF-2 reader (i.e.
 266     SYMBOL_LOCATION_BATON for a LOC_COMPUTED symbol).  "struct
 267     dwarf2_locexpr_baton" is for a symbol with a single location
 268 diff --git a/gdb/dwarf2read.c b/gdb/dwarf2read.c
 269 index 276d2f1..fbf13ce 100644
 270 --- a/gdb/dwarf2read.c
 271 +++ b/gdb/dwarf2read.c
 272 @@ -1847,6 +1847,12 @@ static void free_dwo_file_cleanup (void *);
 273  static void process_cu_includes (void);
 274
 275  static void check_producer (struct dwarf2_cu *cu);
 276 +
 277 +static int
 278 +attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
 279 +                     struct dwarf2_cu *cu, struct dynamic_prop *prop,
 280 +                     const gdb_byte *additional_data, int additional_data_size);
 281 +
 282  \f
 283  /* Various complaints about symbol reading that don't abort the process.  */
 284
 285 @@ -14201,29 +14207,92 @@ read_tag_string_type (struct die_info *die, struct dwarf2_cu *cu)
 286    struct gdbarch *gdbarch = get_objfile_arch (objfile);
 287    struct type *type, *range_type, *index_type, *char_type;
 288    struct attribute *attr;
 289 -  unsigned int length;
 290 +  unsigned int length = UINT_MAX;
 291 +
 292 +  index_type = objfile_type (objfile)->builtin_int;
 293 +  range_type = create_static_range_type (NULL, index_type, 1, length);
 294
 295 +  /* If DW_AT_string_length is defined, the length is stored at some location
 296 +   * in memory. */
 297    attr = dwarf2_attr (die, DW_AT_string_length, cu);
 298    if (attr)
 299      {
 300 -      length = DW_UNSND (attr);
 301 +      if (attr_form_is_block (attr))
 302 +        {
 303 +          struct attribute *byte_size, *bit_size;
 304 +          struct dynamic_prop high;
 305 +
 306 +          byte_size = dwarf2_attr (die, DW_AT_byte_size, cu);
 307 +          bit_size = dwarf2_attr (die, DW_AT_bit_size, cu);
 308 +
 309 +          /* DW_AT_byte_size should never occur together in combination with
 310 +             DW_AT_string_length.  */
 311 +          if ((byte_size == NULL && bit_size != NULL) ||
 312 +                  (byte_size != NULL && bit_size == NULL))
 313 +            complaint (&symfile_complaints, _("DW_AT_byte_size AND "
 314 +                      "DW_AT_bit_size found together at the same time."));
 315 +
 316 +          /* If DW_AT_string_length AND DW_AT_byte_size exist together, it
 317 +             describes the number of bytes that should be read from the length
 318 +             memory location.  */
 319 +          if (byte_size != NULL && bit_size == NULL)
 320 +            {
 321 +              /* Build new dwarf2_locexpr_baton structure with additions to the
 322 +                 data attribute, to reflect DWARF specialities to get address
 323 +                 sizes.  */
 324 +              const gdb_byte append_ops[] = {
 325 +                /* DW_OP_deref_size: size of an address on the target machine
 326 +                   (bytes), where the size will be specified by the next
 327 +                   operand.  */
 328 +                DW_OP_deref_size,
 329 +                /* Operand for DW_OP_deref_size.  */
 330 +                DW_UNSND (byte_size) };
 331 +
 332 +              if (!attr_to_dynamic_prop (attr, die, cu, &high,
 333 +                      append_ops, ARRAY_SIZE (append_ops)))
 334 +                complaint (&symfile_complaints,
 335 +                        _("Could not parse DW_AT_byte_size"));
 336 +            }
 337 +          else if (bit_size != NULL && byte_size == NULL)
 338 +            complaint (&symfile_complaints, _("DW_AT_string_length AND "
 339 +                      "DW_AT_bit_size found but not supported yet."));
 340 +          /* If DW_AT_string_length WITHOUT DW_AT_byte_size exist, the default
 341 +             is the address size of the target machine.  */
 342 +          else
 343 +            {
 344 +              const gdb_byte append_ops[] = { DW_OP_deref };
 345 +
 346 +              if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
 347 +                      ARRAY_SIZE (append_ops)))
 348 +                complaint (&symfile_complaints,
 349 +                        _("Could not parse DW_AT_string_length"));
 350 +            }
 351 +
 352 +          TYPE_RANGE_DATA (range_type)->high = high;
 353 +        }
 354 +      else
 355 +        {
 356 +          TYPE_HIGH_BOUND (range_type) = DW_UNSND (attr);
 357 +          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
 358 +        }
 359      }
 360    else
 361      {
 362 -      /* Check for the DW_AT_byte_size attribute.  */
 363 +      /* Check for the DW_AT_byte_size attribute, which represents the length
 364 +         in this case.  */
 365        attr = dwarf2_attr (die, DW_AT_byte_size, cu);
 366        if (attr)
 367          {
 368 -          length = DW_UNSND (attr);
 369 +          TYPE_HIGH_BOUND (range_type) = DW_UNSND (attr);
 370 +          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
 371          }
 372        else
 373          {
 374 -          length = 1;
 375 +          TYPE_HIGH_BOUND (range_type) = 1;
 376 +          TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
 377          }
 378      }
 379
 380 -  index_type = objfile_type (objfile)->builtin_int;
 381 -  range_type = create_static_range_type (NULL, index_type, 1, length);
 382    char_type = language_string_char_type (cu->language_defn, gdbarch);
 383    type = create_string_type (NULL, char_type, range_type);
 384
 385 @@ -14540,13 +14609,15 @@ read_base_type (struct die_info *die, struct dwarf2_cu *cu)
 386    return set_die_type (die, type, cu);
 387  }
 388
 389 +
 390  /* Parse dwarf attribute if it's a block, reference or constant and put the
 391     resulting value of the attribute into struct bound_prop.
 392     Returns 1 if ATTR could be resolved into PROP, 0 otherwise.  */
 393
 394  static int
 395  attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
 396 -                     struct dwarf2_cu *cu, struct dynamic_prop *prop)
 397 +                     struct dwarf2_cu *cu, struct dynamic_prop *prop,
 398 +                     const gdb_byte *additional_data, int additional_data_size)
 399  {
 400    struct dwarf2_property_baton *baton;
 401    struct obstack *obstack = &cu->objfile->objfile_obstack;
 402 @@ -14559,8 +14630,25 @@ attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
 403        baton = obstack_alloc (obstack, sizeof (*baton));
 404        baton->referenced_type = NULL;
 405        baton->locexpr.per_cu = cu->per_cu;
 406 -      baton->locexpr.size = DW_BLOCK (attr)->size;
 407 -      baton->locexpr.data = DW_BLOCK (attr)->data;
 408 +
 409 +      if (additional_data != NULL && additional_data_size > 0)
 410 +        {
 411 +          gdb_byte *data;
 412 +
 413 +          data = obstack_alloc (&cu->objfile->objfile_obstack,
 414 +                  DW_BLOCK (attr)->size + additional_data_size);
 415 +          memcpy (data, DW_BLOCK (attr)->data, DW_BLOCK (attr)->size);
 416 +          memcpy (data + DW_BLOCK (attr)->size,
 417 +                  additional_data, additional_data_size);
 418 +
 419 +          baton->locexpr.data = data;
 420 +          baton->locexpr.size = DW_BLOCK (attr)->size + additional_data_size;
 421 +        }
 422 +      else
 423 +        {
 424 +          baton->locexpr.data = DW_BLOCK (attr)->data;
 425 +          baton->locexpr.size = DW_BLOCK (attr)->size;
 426 +        }
 427        prop->data.baton = baton;
 428        prop->kind = PROP_LOCEXPR;
 429        gdb_assert (prop->data.baton != NULL);
 430 @@ -14590,8 +14678,28 @@ attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
 431           baton = obstack_alloc (obstack, sizeof (*baton));
 432           baton->referenced_type = die_type (target_die, target_cu);
 433           baton->locexpr.per_cu = cu->per_cu;
 434 -         baton->locexpr.size = DW_BLOCK (target_attr)->size;
 435 -         baton->locexpr.data = DW_BLOCK (target_attr)->data;
 436 +
 437 +         if (additional_data != NULL && additional_data_size > 0)
 438 +           {
 439 +             gdb_byte *data;
 440 +
 441 +             data = obstack_alloc (&cu->objfile->objfile_obstack,
 442 +                     DW_BLOCK (target_attr)->size + additional_data_size);
 443 +             memcpy (data, DW_BLOCK (target_attr)->data,
 444 +                     DW_BLOCK (target_attr)->size);
 445 +             memcpy (data + DW_BLOCK (target_attr)->size,
 446 +                     additional_data, additional_data_size);
 447 +
 448 +             baton->locexpr.data = data;
 449 +             baton->locexpr.size = (DW_BLOCK (target_attr)->size
 450 +                                    + additional_data_size);
 451 +           }
 452 +         else
 453 +           {
 454 +             baton->locexpr.data = DW_BLOCK (target_attr)->data;
 455 +             baton->locexpr.size = DW_BLOCK (target_attr)->size;
 456 +           }
 457 +
 458           prop->data.baton = baton;
 459           prop->kind = PROP_LOCEXPR;
 460           gdb_assert (prop->data.baton != NULL);
 461 @@ -14626,7 +14734,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
 462    struct type *base_type, *orig_base_type;
 463    struct type *range_type;
 464    struct attribute *attr;
 465 -  struct dynamic_prop low, high;
 466 +  struct dynamic_prop low, high, stride;
 467    int low_default_is_valid;
 468    int high_bound_is_count = 0;
 469    const char *name;
 470 @@ -14646,7 +14754,9 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
 471
 472    low.kind = PROP_CONST;
 473    high.kind = PROP_CONST;
 474 +  stride.kind = PROP_CONST;
 475    high.data.const_val = 0;
 476 +  stride.data.const_val = 0;
 477
 478    /* Set LOW_DEFAULT_IS_VALID if current language and DWARF version allow
 479       omitting DW_AT_lower_bound.  */
 480 @@ -14679,19 +14789,26 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
 481        break;
 482      }
 483
 484 +  attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
 485 +  if (attr)
 486 +    if (!attr_to_dynamic_prop (attr, die, cu, &stride, NULL, 0))
 487 +        complaint (&symfile_complaints, _("Missing DW_AT_byte_stride "
 488 +                  "- DIE at 0x%x [in module %s]"),
 489 +             die->offset.sect_off, objfile_name (cu->objfile));
 490 +
 491    attr = dwarf2_attr (die, DW_AT_lower_bound, cu);
 492    if (attr)
 493 -    attr_to_dynamic_prop (attr, die, cu, &low);
 494 +    attr_to_dynamic_prop (attr, die, cu, &low, NULL, 0);
 495    else if (!low_default_is_valid)
 496      complaint (&symfile_complaints, _("Missing DW_AT_lower_bound "
 497                                       "- DIE at 0x%x [in module %s]"),
 498                die->offset.sect_off, objfile_name (cu->objfile));
 499
 500    attr = dwarf2_attr (die, DW_AT_upper_bound, cu);
 501 -  if (!attr_to_dynamic_prop (attr, die, cu, &high))
 502 +  if (!attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))
 503      {
 504        attr = dwarf2_attr (die, DW_AT_count, cu);
 505 -      if (attr_to_dynamic_prop (attr, die, cu, &high))
 506 +      if (attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))
 507         {
 508           /* If bounds are constant do the final calculation here.  */
 509           if (low.kind == PROP_CONST && high.kind == PROP_CONST)
 510 @@ -14755,7 +14872,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu)
 511        && !TYPE_UNSIGNED (base_type) && (high.data.const_val & negative_mask))
 512      high.data.const_val |= negative_mask;
 513
 514 -  range_type = create_range_type (NULL, orig_base_type, &low, &high);
 515 +  range_type = create_range_type (NULL, orig_base_type, &low, &high, &stride);
 516
 517    if (high_bound_is_count)
 518      TYPE_RANGE_DATA (range_type)->flag_upper_bound_is_count = 1;
 519 @@ -21673,6 +21790,8 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
 520  {
 521    struct dwarf2_per_cu_offset_and_type **slot, ofs;
 522    struct objfile *objfile = cu->objfile;
 523 +  struct attribute *attr;
 524 +  struct dynamic_prop prop;
 525
 526    /* For Ada types, make sure that the gnat-specific data is always
 527       initialized (if not already set).  There are a few types where
 528 @@ -21687,6 +21806,43 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu)
 529        && !HAVE_GNAT_AUX_INFO (type))
 530      INIT_GNAT_SPECIFIC (type);
 531
 532 +  /* Read DW_AT_allocated and set in type.  */
 533 +  attr = dwarf2_attr (die, DW_AT_allocated, cu);
 534 +  if (attr_form_is_block (attr))
 535 +    {
 536 +      struct dynamic_prop prop;
 537 +
 538 +      if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
 539 +        {
 540 +          TYPE_ALLOCATED_PROP (type)
 541 +            = obstack_alloc (&objfile->objfile_obstack, sizeof (prop));
 542 +          *TYPE_ALLOCATED_PROP (type) = prop;
 543 +        }
 544 +    }
 545 +
 546 +  /* Read DW_AT_associated and set in type.  */
 547 +  attr = dwarf2_attr (die, DW_AT_associated, cu);
 548 +  if (attr_form_is_block (attr))
 549 +    {
 550 +      struct dynamic_prop prop;
 551 +
 552 +      if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
 553 +        {
 554 +          TYPE_ASSOCIATED_PROP (type)
 555 +            = obstack_alloc (&objfile->objfile_obstack, sizeof (prop));
 556 +          *TYPE_ASSOCIATED_PROP (type) = prop;
 557 +        }
 558 +    }
 559 +
 560 +  /* Read DW_AT_data_location and set in type.  */
 561 +  attr = dwarf2_attr (die, DW_AT_data_location, cu);
 562 +  if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
 563 +    {
 564 +      TYPE_DATA_LOCATION (type)
 565 +        = obstack_alloc (&objfile->objfile_obstack, sizeof (prop));
 566 +      *TYPE_DATA_LOCATION (type) = prop;
 567 +    }
 568 +
 569    if (dwarf2_per_objfile->die_type_hash == NULL)
 570      {
 571        dwarf2_per_objfile->die_type_hash =
 572 diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c
 573 index 8356aab..69e67f4 100644
 574 --- a/gdb/f-typeprint.c
 575 +++ b/gdb/f-typeprint.c
 576 @@ -30,6 +30,7 @@
 577  #include "gdbcore.h"
 578  #include "target.h"
 579  #include "f-lang.h"
 580 +#include "valprint.h"
 581
 582  #include <string.h>
 583  #include <errno.h>
 584 @@ -56,6 +57,17 @@ f_print_type (struct type *type, const char *varstring, struct ui_file *stream,
 585    enum type_code code;
 586    int demangled_args;
 587
 588 +  if (TYPE_NOT_ASSOCIATED (type))
 589 +    {
 590 +      val_print_not_associated (stream);
 591 +      return;
 592 +    }
 593 +  if (TYPE_NOT_ALLOCATED (type))
 594 +    {
 595 +      val_print_not_allocated (stream);
 596 +      return;
 597 +    }
 598 +
 599    f_type_print_base (type, stream, show, level);
 600    code = TYPE_CODE (type);
 601    if ((varstring != NULL && *varstring != '\0')
 602 @@ -170,28 +182,36 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
 603        if (arrayprint_recurse_level == 1)
 604         fprintf_filtered (stream, "(");
 605
 606 -      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
 607 -       f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
 608 -                                    arrayprint_recurse_level);
 609 -
 610 -      lower_bound = f77_get_lowerbound (type);
 611 -      if (lower_bound != 1)    /* Not the default.  */
 612 -       fprintf_filtered (stream, "%d:", lower_bound);
 613 -
 614 -      /* Make sure that, if we have an assumed size array, we
 615 -         print out a warning and print the upperbound as '*'.  */
 616 -
 617 -      if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
 618 -       fprintf_filtered (stream, "*");
 619 +      if (TYPE_NOT_ASSOCIATED (type))
 620 +        val_print_not_associated (stream);
 621 +      else if (TYPE_NOT_ALLOCATED (type))
 622 +        val_print_not_allocated (stream);
 623        else
 624 -       {
 625 -         upper_bound = f77_get_upperbound (type);
 626 -         fprintf_filtered (stream, "%d", upper_bound);
 627 -       }
 628 -
 629 -      if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
 630 -       f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
 631 -                                    arrayprint_recurse_level);
 632 +        {
 633 +
 634 +          if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
 635 +            f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
 636 +                 arrayprint_recurse_level);
 637 +
 638 +          lower_bound = f77_get_lowerbound (type);
 639 +          if (lower_bound != 1)        /* Not the default.  */
 640 +            fprintf_filtered (stream, "%d:", lower_bound);
 641 +
 642 +          /* Make sure that, if we have an assumed size array, we
 643 +             print out a warning and print the upperbound as '*'.  */
 644 +
 645 +          if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
 646 +            fprintf_filtered (stream, "*");
 647 +          else
 648 +            {
 649 +              upper_bound = f77_get_upperbound (type);
 650 +              fprintf_filtered (stream, "%d", upper_bound);
 651 +            }
 652 +
 653 +          if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
 654 +            f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0,
 655 +                 arrayprint_recurse_level);
 656 +      }
 657        if (arrayprint_recurse_level == 1)
 658         fprintf_filtered (stream, ")");
 659        else
 660 diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c
 661 index 408c8cc..38f32e0 100644
 662 --- a/gdb/f-valprint.c
 663 +++ b/gdb/f-valprint.c
 664 @@ -39,8 +39,6 @@
 665
 666  extern void _initialize_f_valprint (void);
 667  static void info_common_command (char *, int);
 668 -static void f77_create_arrayprint_offset_tbl (struct type *,
 669 -                                             struct ui_file *);
 670  static void f77_get_dynamic_length_of_aggregate (struct type *);
 671
 672  int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
 673 @@ -48,15 +46,6 @@ int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
 674  /* Array which holds offsets to be applied to get a row's elements
 675     for a given array.  Array also holds the size of each subarray.  */
 676
 677 -/* The following macro gives us the size of the nth dimension, Where
 678 -   n is 1 based.  */
 679 -
 680 -#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
 681 -
 682 -/* The following gives us the offset for row n where n is 1-based.  */
 683 -
 684 -#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
 685 -
 686  int
 687  f77_get_lowerbound (struct type *type)
 688  {
 689 @@ -114,47 +103,6 @@ f77_get_dynamic_length_of_aggregate (struct type *type)
 690      * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
 691  }
 692
 693 -/* Function that sets up the array offset,size table for the array
 694 -   type "type".  */
 695 -
 696 -static void
 697 -f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
 698 -{
 699 -  struct type *tmp_type;
 700 -  int eltlen;
 701 -  int ndimen = 1;
 702 -  int upper, lower;
 703 -
 704 -  tmp_type = type;
 705 -
 706 -  while (TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)
 707 -    {
 708 -      upper = f77_get_upperbound (tmp_type);
 709 -      lower = f77_get_lowerbound (tmp_type);
 710 -
 711 -      F77_DIM_SIZE (ndimen) = upper - lower + 1;
 712 -
 713 -      tmp_type = TYPE_TARGET_TYPE (tmp_type);
 714 -      ndimen++;
 715 -    }
 716 -
 717 -  /* Now we multiply eltlen by all the offsets, so that later we
 718 -     can print out array elements correctly.  Up till now we
 719 -     know an offset to apply to get the item but we also
 720 -     have to know how much to add to get to the next item.  */
 721 -
 722 -  ndimen--;
 723 -  eltlen = TYPE_LENGTH (tmp_type);
 724 -  F77_DIM_OFFSET (ndimen) = eltlen;
 725 -  while (--ndimen > 0)
 726 -    {
 727 -      eltlen *= F77_DIM_SIZE (ndimen + 1);
 728 -      F77_DIM_OFFSET (ndimen) = eltlen;
 729 -    }
 730 -}
 731 -
 732 -
 733 -
 734  /* Actual function which prints out F77 arrays, Valaddr == address in
 735     the superior.  Address == the address in the inferior.  */
 736
 737 @@ -167,41 +115,62 @@ f77_print_array_1 (int nss, int ndimensions, struct type *type,
 738                    const struct value_print_options *options,
 739                    int *elts)
 740  {
 741 +  struct type *range_type = TYPE_INDEX_TYPE (check_typedef (type));
 742 +  CORE_ADDR addr = address + embedded_offset;
 743 +  LONGEST lowerbound, upperbound;
 744    int i;
 745
 746 +  get_discrete_bounds (range_type, &lowerbound, &upperbound);
 747 +
 748    if (nss != ndimensions)
 749      {
 750 -      for (i = 0;
 751 -          (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max);
 752 +      size_t dim_size;
 753 +      size_t offs = 0;
 754 +      LONGEST byte_stride = abs (TYPE_BYTE_STRIDE (range_type));
 755 +
 756 +      if (byte_stride)
 757 +        dim_size = byte_stride;
 758 +      else
 759 +        dim_size = TYPE_LENGTH (TYPE_TARGET_TYPE (type));
 760 +
 761 +      for (i = lowerbound;
 762 +          (i < upperbound + 1 && (*elts) < options->print_max);
 763            i++)
 764         {
 765 +         struct value *subarray = value_from_contents_and_address
 766 +           (TYPE_TARGET_TYPE (type), value_contents_for_printing_const (val)
 767 +            + offs, addr + offs);
 768 +
 769           fprintf_filtered (stream, "( ");
 770 -         f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
 771 -                            valaddr,
 772 -                            embedded_offset + i * F77_DIM_OFFSET (nss),
 773 -                            address,
 774 -                            stream, recurse, val, options, elts);
 775 +         f77_print_array_1 (nss + 1, ndimensions, value_type (subarray),
 776 +                            value_contents_for_printing (subarray),
 777 +                            value_embedded_offset (subarray),
 778 +                            value_address (subarray),
 779 +                            stream, recurse, subarray, options, elts);
 780 +         offs += dim_size;
 781           fprintf_filtered (stream, ") ");
 782         }
 783 -      if (*elts >= options->print_max && i < F77_DIM_SIZE (nss))
 784 +      if (*elts >= options->print_max && i < upperbound)
 785         fprintf_filtered (stream, "...");
 786      }
 787    else
 788      {
 789 -      for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < options->print_max;
 790 +      for (i = lowerbound; i < upperbound + 1 && (*elts) < options->print_max;
 791            i++, (*elts)++)
 792         {
 793 -         val_print (TYPE_TARGET_TYPE (type),
 794 -                    valaddr,
 795 -                    embedded_offset + i * F77_DIM_OFFSET (ndimensions),
 796 -                    address, stream, recurse,
 797 -                    val, options, current_language);
 798 +         struct value *elt = value_subscript ((struct value *)val, i);
 799 +
 800 +         val_print (value_type (elt),
 801 +                    value_contents_for_printing (elt),
 802 +                    value_embedded_offset (elt),
 803 +                    value_address (elt), stream, recurse,
 804 +                    elt, options, current_language);
 805
 806 -         if (i != (F77_DIM_SIZE (nss) - 1))
 807 +         if (i != upperbound)
 808             fprintf_filtered (stream, ", ");
 809
 810           if ((*elts == options->print_max - 1)
 811 -             && (i != (F77_DIM_SIZE (nss) - 1)))
 812 +             && (i != upperbound))
 813             fprintf_filtered (stream, "...");
 814         }
 815      }
 816 @@ -228,12 +197,6 @@ f77_print_array (struct type *type, const gdb_byte *valaddr,
 817  Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
 818            ndimensions, MAX_FORTRAN_DIMS);
 819
 820 -  /* Since F77 arrays are stored column-major, we set up an
 821 -     offset table to get at the various row's elements.  The
 822 -     offset table contains entries for both offset and subarray size.  */
 823 -
 824 -  f77_create_arrayprint_offset_tbl (type, stream);
 825 -
 826    f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
 827                      address, stream, recurse, val, options, &elts);
 828  }
 829 @@ -378,12 +341,15 @@ f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
 830        fprintf_filtered (stream, "( ");
 831        for (index = 0; index < TYPE_NFIELDS (type); index++)
 832          {
 833 -          int offset = TYPE_FIELD_BITPOS (type, index) / 8;
 834 +         struct value *field = value_field
 835 +           ((struct value *)original_value, index);
 836 +
 837 +          val_print (value_type (field),
 838 +                    value_contents_for_printing (field),
 839 +                    value_embedded_offset (field),
 840 +                    value_address (field), stream, recurse + 1,
 841 +                    field, options, current_language);
 842
 843 -          val_print (TYPE_FIELD_TYPE (type, index), valaddr,
 844 -                    embedded_offset + offset,
 845 -                    address, stream, recurse + 1,
 846 -                    original_value, options, current_language);
 847            if (index != TYPE_NFIELDS (type) - 1)
 848              fputs_filtered (", ", stream);
 849          }
 850 diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c
 851 index e99a2f3..53cae2c 100644
 852 --- a/gdb/gdbtypes.c
 853 +++ b/gdb/gdbtypes.c
 854 @@ -805,7 +805,8 @@ allocate_stub_method (struct type *type)
 855  struct type *
 856  create_range_type (struct type *result_type, struct type *index_type,
 857                    const struct dynamic_prop *low_bound,
 858 -                  const struct dynamic_prop *high_bound)
 859 +                  const struct dynamic_prop *high_bound,
 860 +                  const struct dynamic_prop *stride)
 861  {
 862    if (result_type == NULL)
 863      result_type = alloc_type_copy (index_type);
 864 @@ -820,6 +821,7 @@ create_range_type (struct type *result_type, struct type *index_type,
 865      TYPE_ZALLOC (result_type, sizeof (struct range_bounds));
 866    TYPE_RANGE_DATA (result_type)->low = *low_bound;
 867    TYPE_RANGE_DATA (result_type)->high = *high_bound;
 868 +  TYPE_RANGE_DATA (result_type)->stride = *stride;
 869
 870    if (low_bound->kind == PROP_CONST && low_bound->data.const_val >= 0)
 871      TYPE_UNSIGNED (result_type) = 1;
 872 @@ -841,7 +843,7 @@ struct type *
 873  create_static_range_type (struct type *result_type, struct type *index_type,
 874                           LONGEST low_bound, LONGEST high_bound)
 875  {
 876 -  struct dynamic_prop low, high;
 877 +  struct dynamic_prop low, high, stride;
 878
 879    low.kind = PROP_CONST;
 880    low.data.const_val = low_bound;
 881 @@ -849,7 +851,11 @@ create_static_range_type (struct type *result_type, struct type *index_type,
 882    high.kind = PROP_CONST;
 883    high.data.const_val = high_bound;
 884
 885 -  result_type = create_range_type (result_type, index_type, &low, &high);
 886 +  stride.kind = PROP_CONST;
 887 +  stride.data.const_val = 0;
 888 +
 889 +  result_type = create_range_type (result_type, index_type,
 890 +                                   &low, &high, &stride);
 891
 892    return result_type;
 893  }
 894 @@ -1003,18 +1009,24 @@ create_array_type_with_stride (struct type *result_type,
 895
 896    TYPE_CODE (result_type) = TYPE_CODE_ARRAY;
 897    TYPE_TARGET_TYPE (result_type) = element_type;
 898 -  if (has_static_range (TYPE_RANGE_DATA (range_type)))
 899 +  if (has_static_range (TYPE_RANGE_DATA (range_type))
 900 +      && dwarf2_address_data_valid (result_type))
 901      {
 902 -      LONGEST low_bound, high_bound;
 903 +      LONGEST low_bound, high_bound, byte_stride;
 904
 905        if (get_discrete_bounds (range_type, &low_bound, &high_bound) < 0)
 906         low_bound = high_bound = 0;
 907        CHECK_TYPEDEF (element_type);
 908 +
 909 +      byte_stride = abs (TYPE_BYTE_STRIDE (range_type));
 910 +
 911        /* Be careful when setting the array length.  Ada arrays can be
 912          empty arrays with the high_bound being smaller than the low_bound.
 913          In such cases, the array length should be zero.  */
 914        if (high_bound < low_bound)
 915         TYPE_LENGTH (result_type) = 0;
 916 +      else if (byte_stride > 0)
 917 +       TYPE_LENGTH (result_type) = byte_stride * (high_bound - low_bound + 1);
 918        else if (bit_stride > 0)
 919         TYPE_LENGTH (result_type) =
 920           (bit_stride * (high_bound - low_bound + 1) + 7) / 8;
 921 @@ -1616,12 +1628,31 @@ stub_noname_complaint (void)
 922  static int
 923  is_dynamic_type_internal (struct type *type, int top_level)
 924  {
 925 +  int index;
 926 +
 927 +  if (!type)
 928 +    return 0;
 929 +
 930    type = check_typedef (type);
 931
 932    /* We only want to recognize references at the outermost level.  */
 933    if (top_level && TYPE_CODE (type) == TYPE_CODE_REF)
 934      type = check_typedef (TYPE_TARGET_TYPE (type));
 935
 936 +  if (TYPE_ASSOCIATED_PROP (type))
 937 +    return 1;
 938 +
 939 +  if (TYPE_ALLOCATED_PROP (type))
 940 +    return 1;
 941 +
 942 +  /* Scan field types in the Fortran case for nested dynamic types.
 943 +     This will be done only for Fortran as in the C++ case an endless recursion
 944 +     can occur in the area of classes.  */
 945 +  if (current_language->la_language == language_fortran)
 946 +    for (index = 0; index < TYPE_NFIELDS (type); index++)
 947 +      if (is_dynamic_type (TYPE_FIELD_TYPE (type, index)))
 948 +        return 1;
 949 +
 950    switch (TYPE_CODE (type))
 951      {
 952      case TYPE_CODE_RANGE:
 953 @@ -1631,11 +1662,19 @@ is_dynamic_type_internal (struct type *type, int top_level)
 954        {
 955         gdb_assert (TYPE_NFIELDS (type) == 1);
 956
 957 -       /* The array is dynamic if either the bounds are dynamic,
 958 -          or the elements it contains have a dynamic contents.  */
 959 +       /* The array is dynamic if either
 960 +     - the bounds are dynamic,
 961 +          - the elements it contains have a dynamic contents
 962 +     - a data_locaton attribute was found.  */
 963         if (is_dynamic_type_internal (TYPE_INDEX_TYPE (type), 0))
 964           return 1;
 965 -       return is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0);
 966 +       else if (TYPE_DATA_LOCATION (type) != NULL
 967 +                && (TYPE_DATA_LOCATION_KIND (type) == PROP_LOCEXPR
 968 +                    || TYPE_DATA_LOCATION_KIND (type) == PROP_LOCLIST))
 969 +    return 1;
 970 +  else
 971 +    return is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0);
 972 +       break;
 973        }
 974
 975      case TYPE_CODE_STRUCT:
 976 @@ -1648,6 +1687,17 @@ is_dynamic_type_internal (struct type *type, int top_level)
 977               && is_dynamic_type_internal (TYPE_FIELD_TYPE (type, i), 0))
 978             return 1;
 979        }
 980 +    case TYPE_CODE_PTR:
 981 +      {
 982 +        if (TYPE_TARGET_TYPE (type)
 983 +            && TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
 984 +          return is_dynamic_type (check_typedef (TYPE_TARGET_TYPE (type)));
 985 +
 986 +        return 0;
 987 +        break;
 988 +      }
 989 +    default:
 990 +      return 0;
 991        break;
 992      }
 993
 994 @@ -1666,22 +1716,23 @@ static struct type *resolve_dynamic_type_internal (struct type *type,
 995                                                    CORE_ADDR addr,
 996                                                    int top_level);
 997
 998 -/* Given a dynamic range type (dyn_range_type), return a static version
 999 -   of that type.  */
1000 +/* Given a dynamic range type (dyn_range_type) and address,
1001 +   return a static version of that type.  */
1002
1003  static struct type *
1004 -resolve_dynamic_range (struct type *dyn_range_type)
1005 +resolve_dynamic_range (struct type *dyn_range_type, CORE_ADDR addr)
1006  {
1007    CORE_ADDR value;
1008    struct type *static_range_type;
1009    const struct dynamic_prop *prop;
1010    const struct dwarf2_locexpr_baton *baton;
1011 -  struct dynamic_prop low_bound, high_bound;
1012 +  struct dynamic_prop low_bound, high_bound, stride;
1013 +  struct type *range_copy = copy_type (dyn_range_type);
1014
1015    gdb_assert (TYPE_CODE (dyn_range_type) == TYPE_CODE_RANGE);
1016
1017    prop = &TYPE_RANGE_DATA (dyn_range_type)->low;
1018 -  if (dwarf2_evaluate_property (prop, &value))
1019 +  if (dwarf2_evaluate_property (prop, addr, &value))
1020      {
1021        low_bound.kind = PROP_CONST;
1022        low_bound.data.const_val = value;
1023 @@ -1693,7 +1744,7 @@ resolve_dynamic_range (struct type *dyn_range_type)
1024      }
1025
1026    prop = &TYPE_RANGE_DATA (dyn_range_type)->high;
1027 -  if (dwarf2_evaluate_property (prop, &value))
1028 +  if (dwarf2_evaluate_property (prop, addr, &value))
1029      {
1030        high_bound.kind = PROP_CONST;
1031        high_bound.data.const_val = value;
1032 @@ -1707,10 +1758,17 @@ resolve_dynamic_range (struct type *dyn_range_type)
1033        high_bound.kind = PROP_UNDEFINED;
1034        high_bound.data.const_val = 0;
1035      }
1036 +
1037 +  prop = &TYPE_RANGE_DATA (dyn_range_type)->stride;
1038 +  if (dwarf2_evaluate_property (prop, addr, &value))
1039 +    {
1040 +      stride.kind = PROP_CONST;
1041 +      stride.data.const_val = value;
1042 +    }
1043
1044 -  static_range_type = create_range_type (copy_type (dyn_range_type),
1045 -                                        TYPE_TARGET_TYPE (dyn_range_type),
1046 -                                        &low_bound, &high_bound);
1047 +  static_range_type = create_range_type (range_copy,
1048 +                                        TYPE_TARGET_TYPE (range_copy),
1049 +                                        &low_bound, &high_bound, &stride);
1050    TYPE_RANGE_DATA (static_range_type)->flag_bound_evaluated = 1;
1051    return static_range_type;
1052  }
1053 @@ -1720,29 +1778,52 @@ resolve_dynamic_range (struct type *dyn_range_type)
1054     of the associated array.  */
1055
1056  static struct type *
1057 -resolve_dynamic_array (struct type *type)
1058 +resolve_dynamic_array (struct type *type, CORE_ADDR addr)
1059  {
1060    CORE_ADDR value;
1061    struct type *elt_type;
1062    struct type *range_type;
1063    struct type *ary_dim;
1064 +  struct dynamic_prop *prop;
1065 +  struct type *copy = copy_type (type);
1066
1067 -  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
1068 +  gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY
1069 +              || TYPE_CODE (type) == TYPE_CODE_STRING);
1070
1071    elt_type = type;
1072    range_type = check_typedef (TYPE_INDEX_TYPE (elt_type));
1073 -  range_type = resolve_dynamic_range (range_type);
1074 +  range_type = resolve_dynamic_range (range_type, addr);
1075 +
1076 +  prop = TYPE_ALLOCATED_PROP (type);
1077 +  if (dwarf2_evaluate_property (prop, addr, &value))
1078 +    {
1079 +      TYPE_ALLOCATED_PROP (copy)->kind = PROP_CONST;
1080 +      TYPE_ALLOCATED_PROP (copy)->data.const_val = value;
1081 +    }
1082 +
1083 +  prop = TYPE_ASSOCIATED_PROP (type);
1084 +  if (dwarf2_evaluate_property (prop, addr, &value))
1085 +    {
1086 +      TYPE_ASSOCIATED_PROP (copy)->kind = PROP_CONST;
1087 +      TYPE_ASSOCIATED_PROP (copy)->data.const_val = value;
1088 +    }
1089
1090    ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));
1091
1092 -  if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)
1093 -    elt_type = resolve_dynamic_array (TYPE_TARGET_TYPE (type));
1094 +  if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY
1095 +          || TYPE_CODE (ary_dim) == TYPE_CODE_STRING))
1096 +    elt_type = resolve_dynamic_array (TYPE_TARGET_TYPE (copy), addr);
1097    else
1098      elt_type = TYPE_TARGET_TYPE (type);
1099
1100 -  return create_array_type (copy_type (type),
1101 -                           elt_type,
1102 -                           range_type);
1103 +  if (TYPE_CODE (type) == TYPE_CODE_STRING)
1104 +    return create_string_type (copy,
1105 +            elt_type,
1106 +            range_type);
1107 +  else
1108 +    return create_array_type (copy,
1109 +            elt_type,
1110 +            range_type);
1111  }
1112
1113  /* Resolve dynamic bounds of members of the union TYPE to static
1114 @@ -1846,6 +1927,8 @@ resolve_dynamic_type_internal (struct type *type, CORE_ADDR addr,
1115  {
1116    struct type *real_type = check_typedef (type);
1117    struct type *resolved_type = type;
1118 +  const struct dynamic_prop *prop;
1119 +  CORE_ADDR value;
1120
1121    if (!is_dynamic_type_internal (real_type, top_level))
1122      return type;
1123 @@ -1871,11 +1954,12 @@ resolve_dynamic_type_internal (struct type *type, CORE_ADDR addr,
1124         }
1125
1126        case TYPE_CODE_ARRAY:
1127 -       resolved_type = resolve_dynamic_array (type);
1128 +      case TYPE_CODE_STRING:
1129 +       resolved_type = resolve_dynamic_array (type, addr);
1130         break;
1131
1132        case TYPE_CODE_RANGE:
1133 -       resolved_type = resolve_dynamic_range (type);
1134 +       resolved_type = resolve_dynamic_range (type, addr);
1135         break;
1136
1137      case TYPE_CODE_UNION:
1138 @@ -1887,6 +1971,25 @@ resolve_dynamic_type_internal (struct type *type, CORE_ADDR addr,
1139        break;
1140      }
1141
1142 +  /* Resolve data_location attribute.  */
1143 +  prop = TYPE_DATA_LOCATION (resolved_type);
1144 +  if (dwarf2_evaluate_property (prop, addr, &value))
1145 +    {
1146 +      struct type *range_type = TYPE_INDEX_TYPE (resolved_type);
1147 +
1148 +      /* Adjust the data location with the value of byte stride if set, which
1149 +         can describe the separation between successive elements along the
1150 +         dimension.  */
1151 +      if (TYPE_BYTE_STRIDE (range_type) < 0)
1152 +        value += (TYPE_HIGH_BOUND (range_type) - TYPE_LOW_BOUND (range_type))
1153 +                  * TYPE_BYTE_STRIDE (range_type);
1154 +
1155 +      TYPE_DATA_LOCATION_ADDR (resolved_type) = value;
1156 +      TYPE_DATA_LOCATION_KIND (resolved_type) = PROP_CONST;
1157 +    }
1158 +  else
1159 +    TYPE_DATA_LOCATION (resolved_type) = NULL;
1160 +
1161    return resolved_type;
1162  }
1163
1164 @@ -4104,6 +4207,27 @@ copy_type_recursive (struct objfile *objfile,
1165        *TYPE_RANGE_DATA (new_type) = *TYPE_RANGE_DATA (type);
1166      }
1167
1168 +  /* Copy the data location information.  */
1169 +  if (TYPE_DATA_LOCATION (type) != NULL)
1170 +    {
1171 +      TYPE_DATA_LOCATION (new_type) = xmalloc (sizeof (struct dynamic_prop));
1172 +      *TYPE_DATA_LOCATION (new_type) = *TYPE_DATA_LOCATION (type);
1173 +    }
1174 +
1175 +  /* Copy allocated information.  */
1176 +  if (TYPE_ALLOCATED_PROP (type) != NULL)
1177 +    {
1178 +      TYPE_ALLOCATED_PROP (new_type) = xmalloc (sizeof (struct dynamic_prop));
1179 +      *TYPE_ALLOCATED_PROP (new_type) = *TYPE_ALLOCATED_PROP (type);
1180 +    }
1181 +
1182 +  /* Copy associated information.  */
1183 +  if (TYPE_ASSOCIATED_PROP (type) != NULL)
1184 +    {
1185 +      TYPE_ASSOCIATED_PROP (new_type) = xmalloc (sizeof (struct dynamic_prop));
1186 +      *TYPE_ASSOCIATED_PROP (new_type) = *TYPE_ASSOCIATED_PROP (type);
1187 +    }
1188 +
1189    /* Copy pointers to other types.  */
1190    if (TYPE_TARGET_TYPE (type))
1191      TYPE_TARGET_TYPE (new_type) =
1192 @@ -4150,6 +4274,44 @@ copy_type (const struct type *type)
1193    memcpy (TYPE_MAIN_TYPE (new_type), TYPE_MAIN_TYPE (type),
1194           sizeof (struct main_type));
1195
1196 +  if (TYPE_ALLOCATED_PROP (type))
1197 +    {
1198 +      TYPE_ALLOCATED_PROP (new_type)
1199 +              = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
1200 +                                struct dynamic_prop);
1201 +      memcpy (TYPE_ALLOCATED_PROP (new_type), TYPE_ALLOCATED_PROP (type),
1202 +        sizeof (struct dynamic_prop));
1203 +    }
1204 +
1205 +  if (TYPE_ASSOCIATED_PROP (type))
1206 +    {
1207 +      TYPE_ASSOCIATED_PROP (new_type)
1208 +              = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
1209 +                                struct dynamic_prop);
1210 +      memcpy (TYPE_ASSOCIATED_PROP (new_type), TYPE_ASSOCIATED_PROP (type),
1211 +        sizeof (struct dynamic_prop));
1212 +    }
1213 +
1214 +  if (TYPE_DATA_LOCATION (type))
1215 +    {
1216 +      TYPE_DATA_LOCATION (new_type)
1217 +              = OBSTACK_ZALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
1218 +                                struct dynamic_prop);
1219 +      memcpy (TYPE_DATA_LOCATION (new_type), TYPE_DATA_LOCATION (type),
1220 +        sizeof (struct dynamic_prop));
1221 +    }
1222 +
1223 +  if (TYPE_NFIELDS (type))
1224 +    {
1225 +      int nfields = TYPE_NFIELDS (type);
1226 +
1227 +      TYPE_FIELDS (new_type)
1228 +              = OBSTACK_CALLOC (&TYPE_OWNER (type).objfile->objfile_obstack,
1229 +                                nfields, struct field);
1230 +      memcpy (TYPE_FIELDS (new_type), TYPE_FIELDS (type),
1231 +        nfields * sizeof (struct field));
1232 +   }
1233 +
1234    return new_type;
1235  }
1236  \f
1237 diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h
1238 index 5008ef4..436edf8 100644
1239 --- a/gdb/gdbtypes.h
1240 +++ b/gdb/gdbtypes.h
1241 @@ -669,6 +669,10 @@ struct main_type
1242
1243        struct dynamic_prop high;
1244
1245 +      /* * Stride of range.  */
1246 +
1247 +      struct dynamic_prop stride;
1248 +
1249        /* True if HIGH range bound contains the number of elements in the
1250          subrange. This affects how the final hight bound is computed.  */
1251
1252 @@ -724,6 +728,23 @@ struct main_type
1253
1254      struct func_type *func_stuff;
1255    } type_specific;
1256 +
1257 +  /* * Contains a location description value for the current type. Evaluating
1258 +     this field yields to the location of the data for an object.  */
1259 +
1260 +  struct dynamic_prop *data_location;
1261 +
1262 +  /* Structure for DW_AT_allocated.
1263 +     The presence of this attribute indicates that the object of the type
1264 +     can be allocated/deallocated.  The value can be a dwarf expression,
1265 +     reference, or a constant.  */
1266 +  struct dynamic_prop *allocated;
1267 +
1268 +  /* Structure for DW_AT_associated.
1269 +     The presence of this attribute indicated that the object of the type
1270 +     can be associated.  The value can be a dwarf expression,
1271 +     reference, or a constant.  */
1272 +  struct dynamic_prop *associated;
1273  };
1274
1275  /* * A ``struct type'' describes a particular instance of a type, with
1276 @@ -1202,6 +1223,39 @@ extern void allocate_gnat_aux_type (struct type *);
1277    TYPE_RANGE_DATA(range_type)->high.kind
1278  #define TYPE_LOW_BOUND_KIND(range_type) \
1279    TYPE_RANGE_DATA(range_type)->low.kind
1280 +#define TYPE_BYTE_STRIDE(range_type) \
1281 +  TYPE_RANGE_DATA(range_type)->stride.data.const_val
1282 +#define TYPE_BYTE_STRIDE_BLOCK(range_type) \
1283 +  TYPE_RANGE_DATA(range_type)->stride.data.locexpr
1284 +#define TYPE_BYTE_STRIDE_LOCLIST(range_type) \
1285 +  TYPE_RANGE_DATA(range_type)->stride.data.loclist
1286 +#define TYPE_BYTE_STRIDE_KIND(range_type) \
1287 +  TYPE_RANGE_DATA(range_type)->stride.kind
1288 +
1289 +
1290 +/* Attribute accessors for the type data location.  */
1291 +#define TYPE_DATA_LOCATION(thistype) \
1292 +  TYPE_MAIN_TYPE(thistype)->data_location
1293 +#define TYPE_DATA_LOCATION_BATON(thistype) \
1294 +  TYPE_DATA_LOCATION (thistype)->data.baton
1295 +#define TYPE_DATA_LOCATION_ADDR(thistype) \
1296 +  TYPE_DATA_LOCATION (thistype)->data.const_val
1297 +#define TYPE_DATA_LOCATION_KIND(thistype) \
1298 +  TYPE_DATA_LOCATION (thistype)->kind
1299 +#define TYPE_ALLOCATED_PROP(thistype) TYPE_MAIN_TYPE(thistype)->allocated
1300 +#define TYPE_ASSOCIATED_PROP(thistype) TYPE_MAIN_TYPE(thistype)->associated
1301 +
1302 +/* Allocated status of type object.  If set to non-zero it means the object
1303 +   is allocated. A zero value means it is not allocated.  */
1304 +#define TYPE_NOT_ALLOCATED(t)  (TYPE_ALLOCATED_PROP (t) \
1305 +  && TYPE_ALLOCATED_PROP (t)->kind == PROP_CONST \
1306 +  && !TYPE_ALLOCATED_PROP (t)->data.const_val)
1307 +
1308 +/* Associated status of type object.  If set to non-zero it means the object
1309 +   is associated. A zero value means it is not associated.  */
1310 +#define TYPE_NOT_ASSOCIATED(t)  (TYPE_ASSOCIATED_PROP (t) \
1311 +  && TYPE_ASSOCIATED_PROP (t)->kind == PROP_CONST \
1312 +  && !TYPE_ASSOCIATED_PROP (t)->data.const_val)
1313
1314  /* Moto-specific stuff for FORTRAN arrays.  */
1315
1316 @@ -1209,6 +1263,9 @@ extern void allocate_gnat_aux_type (struct type *);
1317     TYPE_HIGH_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))
1318  #define TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED(arraytype) \
1319     TYPE_LOW_BOUND_UNDEFINED(TYPE_INDEX_TYPE(arraytype))
1320 +#define TYPE_ARRAY_STRIDE_IS_UNDEFINED(arraytype) \
1321 +   (TYPE_BYTE_STRIDE(TYPE_INDEX_TYPE(arraytype)) == 0)
1322 +
1323
1324  #define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \
1325     (TYPE_HIGH_BOUND(TYPE_INDEX_TYPE((arraytype))))
1326 @@ -1677,6 +1734,7 @@ extern struct type *create_array_type_with_stride
1327
1328  extern struct type *create_range_type (struct type *, struct type *,
1329                                        const struct dynamic_prop *,
1330 +                                      const struct dynamic_prop *,
1331                                        const struct dynamic_prop *);
1332
1333  extern struct type *create_array_type (struct type *, struct type *,
1334 diff --git a/gdb/testsuite/gdb.fortran/vla-alloc-assoc.exp b/gdb/testsuite/gdb.fortran/vla-alloc-assoc.exp
1335 new file mode 100644
1336 index 0000000..20607c3
1337 --- /dev/null
1338 +++ b/gdb/testsuite/gdb.fortran/vla-alloc-assoc.exp
1339 @@ -0,0 +1,65 @@
1340 +# Copyright 2014 Free Software Foundation, Inc.
1341 +
1342 +# This program is free software; you can redistribute it and/or modify
1343 +# it under the terms of the GNU General Public License as published by
1344 +# the Free Software Foundation; either version 3 of the License, or
1345 +# (at your option) any later version.
1346 +#
1347 +# This program is distributed in the hope that it will be useful,
1348 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1349 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1350 +# GNU General Public License for more details.
1351 +#
1352 +# You should have received a copy of the GNU General Public License
1353 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1354 +
1355 +standard_testfile "vla.f90"
1356 +
1357 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1358 +    {debug f90 quiet}] } {
1359 +    return -1
1360 +}
1361 +
1362 +if ![runto MAIN__] then {
1363 +    perror "couldn't run to breakpoint MAIN__"
1364 +    continue
1365 +}
1366 +
1367 +# Check the association status of various types of VLA's
1368 +# and pointer to VLA's.
1369 +gdb_breakpoint [gdb_get_line_number "vla1-allocated"]
1370 +gdb_continue_to_breakpoint "vla1-allocated"
1371 +gdb_test "print l" " = \\.TRUE\\." \
1372 +  "print vla1 allocation status (allocated)"
1373 +
1374 +gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
1375 +gdb_continue_to_breakpoint "vla2-allocated"
1376 +gdb_test "print l" " = \\.TRUE\\." \
1377 +  "print vla2 allocation status (allocated)"
1378 +
1379 +gdb_breakpoint [gdb_get_line_number "pvla-associated"]
1380 +gdb_continue_to_breakpoint "pvla-associated"
1381 +gdb_test "print l" " = \\.TRUE\\." \
1382 +  "print pvla associated status (associated)"
1383 +
1384 +gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
1385 +gdb_continue_to_breakpoint "pvla-re-associated"
1386 +gdb_test "print l" " = \\.TRUE\\." \
1387 +  "print pvla associated status (re-associated)"
1388 +
1389 +gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
1390 +gdb_continue_to_breakpoint "pvla-deassociated"
1391 +gdb_test "print l" " = \\.FALSE\\." \
1392 +  "print pvla allocation status (deassociated)"
1393 +
1394 +gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
1395 +gdb_continue_to_breakpoint "vla1-deallocated"
1396 +gdb_test "print l" " = \\.FALSE\\." \
1397 +  "print vla1 allocation status (deallocated)"
1398 +gdb_test "print vla1" " = <not allocated>" \
1399 +  "print deallocated vla1"
1400 +
1401 +gdb_breakpoint [gdb_get_line_number "vla2-deallocated"]
1402 +gdb_continue_to_breakpoint "vla2-deallocated"
1403 +gdb_test "print l" " = \\.FALSE\\." "print vla2 deallocated"
1404 +gdb_test "print vla2" " = <not allocated>" "print deallocated vla2"
1405 diff --git a/gdb/testsuite/gdb.fortran/vla-datatypes.exp b/gdb/testsuite/gdb.fortran/vla-datatypes.exp
1406 new file mode 100644
1407 index 0000000..20276d6
1408 --- /dev/null
1409 +++ b/gdb/testsuite/gdb.fortran/vla-datatypes.exp
1410 @@ -0,0 +1,82 @@
1411 +# Copyright 2014 Free Software Foundation, Inc.
1412 +
1413 +# This program is free software; you can redistribute it and/or modify
1414 +# it under the terms of the GNU General Public License as published by
1415 +# the Free Software Foundation; either version 3 of the License, or
1416 +# (at your option) any later version.
1417 +#
1418 +# This program is distributed in the hope that it will be useful,
1419 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1420 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1421 +# GNU General Public License for more details.
1422 +#
1423 +# You should have received a copy of the GNU General Public License
1424 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1425 +
1426 +standard_testfile ".f90"
1427 +
1428 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1429 +    {debug f90 quiet}] } {
1430 +    return -1
1431 +}
1432 +
1433 +# check that all fortran standard datatypes will be
1434 +# handled correctly when using as VLA's
1435 +
1436 +if ![runto MAIN__] then {
1437 +    perror "couldn't run to breakpoint MAIN__"
1438 +    continue
1439 +}
1440 +
1441 +gdb_breakpoint [gdb_get_line_number "vlas-allocated"]
1442 +gdb_continue_to_breakpoint "vlas-allocated"
1443 +gdb_test "next" " = allocated\\\(realvla\\\)" \
1444 +  "next to allocation status of intvla"
1445 +gdb_test "print l" " = \\.TRUE\\." "intvla allocated"
1446 +gdb_test "next" " = allocated\\\(complexvla\\\)" \
1447 +  "next to allocation status of realvla"
1448 +gdb_test "print l" " = \\.TRUE\\." "realvla allocated"
1449 +gdb_test "next" " = allocated\\\(logicalvla\\\)" \
1450 +  "next to allocation status of complexvla"
1451 +gdb_test "print l" " = \\.TRUE\\." "complexvla allocated"
1452 +gdb_test "next" " = allocated\\\(charactervla\\\)" \
1453 +  "next to allocation status of logicalvla"
1454 +gdb_test "print l" " = \\.TRUE\\." "logicalvla allocated"
1455 +gdb_test "next" "intvla\\\(:,:,:\\\) = 1" \
1456 +  "next to allocation status of charactervla"
1457 +gdb_test "print l" " = \\.TRUE\\." "charactervla allocated"
1458 +
1459 +gdb_breakpoint [gdb_get_line_number "vlas-initialized"]
1460 +gdb_continue_to_breakpoint "vlas-initialized"
1461 +gdb_test "ptype intvla" "type = integer\\\(kind=4\\\) \\\(11,22,33\\\)" \
1462 +  "ptype intvla"
1463 +gdb_test "ptype realvla" "type = real\\\(kind=4\\\) \\\(11,22,33\\\)" \
1464 +  "ptype realvla"
1465 +gdb_test "ptype complexvla" "type = complex\\\(kind=4\\\) \\\(11,22,33\\\)" \
1466 +  "ptype complexvla"
1467 +gdb_test "ptype logicalvla" "type = logical\\\(kind=4\\\) \\\(11,22,33\\\)" \
1468 +  "ptype logicalvla"
1469 +gdb_test "ptype charactervla" "type = character\\\*1 \\\(11,22,33\\\)" \
1470 +  "ptype charactervla"
1471 +
1472 +gdb_test "print intvla(5,5,5)" " = 1" "print intvla(5,5,5) (1st)"
1473 +gdb_test "print realvla(5,5,5)" " = 3.14\\d+" \
1474 +  "print realvla(5,5,5) (1st)"
1475 +gdb_test "print complexvla(5,5,5)" " = \\\(2,-3\\\)" \
1476 +  "print complexvla(5,5,5) (1st)"
1477 +gdb_test "print logicalvla(5,5,5)" " = \\.TRUE\\." \
1478 +  "print logicalvla(5,5,5) (1st)"
1479 +gdb_test "print charactervla(5,5,5)" " = 'K'" \
1480 +  "print charactervla(5,5,5) (1st)"
1481 +
1482 +gdb_breakpoint [gdb_get_line_number "vlas-modified"]
1483 +gdb_continue_to_breakpoint "vlas-modified"
1484 +gdb_test "print intvla(5,5,5)" " = 42" "print intvla(5,5,5) (2nd)"
1485 +gdb_test "print realvla(5,5,5)" " = 4.13\\d+" \
1486 +  "print realvla(5,5,5) (2nd)"
1487 +gdb_test "print complexvla(5,5,5)" " = \\\(-3,2\\\)" \
1488 +  "print complexvla(5,5,5) (2nd)"
1489 +gdb_test "print logicalvla(5,5,5)" " = \\.FALSE\\." \
1490 +  "print logicalvla(5,5,5) (2nd)"
1491 +gdb_test "print charactervla(5,5,5)" " = 'X'" \
1492 +  "print charactervla(5,5,5) (2nd)"
1493 diff --git a/gdb/testsuite/gdb.fortran/vla-datatypes.f90 b/gdb/testsuite/gdb.fortran/vla-datatypes.f90
1494 new file mode 100644
1495 index 0000000..b11879a
1496 --- /dev/null
1497 +++ b/gdb/testsuite/gdb.fortran/vla-datatypes.f90
1498 @@ -0,0 +1,51 @@
1499 +! Copyright 2014 Free Software Foundation, Inc.
1500 +!
1501 +! This program is free software; you can redistribute it and/or modify
1502 +! it under the terms of the GNU General Public License as published by
1503 +! the Free Software Foundation; either version 2 of the License, or
1504 +! (at your option) any later version.
1505 +!
1506 +! This program is distributed in the hope that it will be useful,
1507 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
1508 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1509 +! GNU General Public License for more details.
1510 +!
1511 +! You should have received a copy of the GNU General Public License
1512 +! along with this program; if not, write to the Free Software
1513 +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
1514 +
1515 +program vla_primitives
1516 +  integer, allocatable    :: intvla(:, :, :)
1517 +  real, allocatable       :: realvla(:, :, :)
1518 +  complex, allocatable    :: complexvla(:, :, :)
1519 +  logical, allocatable    :: logicalvla(:, :, :)
1520 +  character, allocatable  :: charactervla(:, :, :)
1521 +  logical                 :: l
1522 +
1523 +  allocate (intvla (11,22,33))
1524 +  allocate (realvla (11,22,33))
1525 +  allocate (complexvla (11,22,33))
1526 +  allocate (logicalvla (11,22,33))
1527 +  allocate (charactervla (11,22,33))
1528 +
1529 +  l = allocated(intvla)                   ! vlas-allocated
1530 +  l = allocated(realvla)
1531 +  l = allocated(complexvla)
1532 +  l = allocated(logicalvla)
1533 +  l = allocated(charactervla)
1534 +
1535 +  intvla(:,:,:) = 1
1536 +  realvla(:,:,:) = 3.14
1537 +  complexvla(:,:,:) = cmplx(2.0,-3.0)
1538 +  logicalvla(:,:,:) = .TRUE.
1539 +  charactervla(:,:,:) = char(75)
1540 +
1541 +  intvla(5,5,5) = 42                      ! vlas-initialized
1542 +  realvla(5,5,5) = 4.13
1543 +  complexvla(5,5,5) = cmplx(-3.0,2.0)
1544 +  logicalvla(5,5,5) = .FALSE.
1545 +  charactervla(5,5,5) = 'X'
1546 +
1547 +  ! dummy statement for bp
1548 +  l = .FALSE.                             ! vlas-modified
1549 +end program vla_primitives
1550 diff --git a/gdb/testsuite/gdb.fortran/vla-func.exp b/gdb/testsuite/gdb.fortran/vla-func.exp
1551 new file mode 100644
1552 index 0000000..f0f236b
1553 --- /dev/null
1554 +++ b/gdb/testsuite/gdb.fortran/vla-func.exp
1555 @@ -0,0 +1,61 @@
1556 +# Copyright 2014 Free Software Foundation, Inc.
1557 +
1558 +# This program is free software; you can redistribute it and/or modify
1559 +# it under the terms of the GNU General Public License as published by
1560 +# the Free Software Foundation; either version 3 of the License, or
1561 +# (at your option) any later version.
1562 +#
1563 +# This program is distributed in the hope that it will be useful,
1564 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1565 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1566 +# GNU General Public License for more details.
1567 +#
1568 +# You should have received a copy of the GNU General Public License
1569 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1570 +
1571 +standard_testfile ".f90"
1572 +
1573 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1574 +    {debug f90 quiet}] } {
1575 +    return -1
1576 +}
1577 +
1578 +if ![runto MAIN__] then {
1579 +    perror "couldn't run to breakpoint MAIN__"
1580 +    continue
1581 +}
1582 +
1583 +# Check VLA passed to first Fortran function.
1584 +gdb_breakpoint [gdb_get_line_number "func1-vla-passed"]
1585 +gdb_continue_to_breakpoint "func1-vla-passed"
1586 +gdb_test "print vla" " = \\( *\\( *22, *22, *22,\[()22, .\]*\\)" \
1587 +  "print vla (func1)"
1588 +gdb_test "ptype vla" "type = integer\\\(kind=4\\\) \\\(10,10\\\)" \
1589 +  "ptype vla (func1)"
1590 +
1591 +gdb_breakpoint [gdb_get_line_number "func1-vla-modified"]
1592 +gdb_continue_to_breakpoint "func1-vla-modified"
1593 +gdb_test "print vla(5,5)" " = 55" "print vla(5,5) (func1)"
1594 +gdb_test "print vla(7,7)" " = 77" "print vla(5,5) (func1)"
1595 +
1596 +# Check if the values are correct after returning from func1
1597 +gdb_breakpoint [gdb_get_line_number "func1-returned"]
1598 +gdb_continue_to_breakpoint "func1-returned"
1599 +gdb_test "print ret" " = .TRUE." "print ret after func1 returned"
1600 +
1601 +# Check VLA passed to second Fortran function
1602 +gdb_breakpoint [gdb_get_line_number "func2-vla-passed"]
1603 +gdb_continue_to_breakpoint "func2-vla-passed"
1604 +gdb_test "print vla" \
1605 +  " = \\\(44, 44, 44, 44, 44, 44, 44, 44, 44, 44\\\)" \
1606 +  "print vla (func2)"
1607 +gdb_test "ptype vla" "type = integer\\\(kind=4\\\) \\\(10\\\)" \
1608 +  "ptype vla (func2)"
1609 +
1610 +# Check if the returned VLA has the correct values and ptype.
1611 +gdb_breakpoint [gdb_get_line_number "func2-returned"]
1612 +gdb_continue_to_breakpoint "func2-returned"
1613 +gdb_test "print vla3" " = \\\(1, 2, 44, 4, 44, 44, 44, 8, 44, 44\\\)" \
1614 +  "print vla3 (after func2)"
1615 +gdb_test "ptype vla3" "type = integer\\\(kind=4\\\) \\\(10\\\)" \
1616 +  "ptype vla3 (after func2)"
1617 diff --git a/gdb/testsuite/gdb.fortran/vla-func.f90 b/gdb/testsuite/gdb.fortran/vla-func.f90
1618 new file mode 100644
1619 index 0000000..4f45da1
1620 --- /dev/null
1621 +++ b/gdb/testsuite/gdb.fortran/vla-func.f90
1622 @@ -0,0 +1,71 @@
1623 +! Copyright 2014 Free Software Foundation, Inc.
1624 +!
1625 +! This program is free software; you can redistribute it and/or modify
1626 +! it under the terms of the GNU General Public License as published by
1627 +! the Free Software Foundation; either version 2 of the License, or
1628 +! (at your option) any later version.
1629 +!
1630 +! This program is distributed in the hope that it will be useful,
1631 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
1632 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1633 +! GNU General Public License for more details.
1634 +!
1635 +! You should have received a copy of the GNU General Public License
1636 +! along with this program; if not, write to the Free Software
1637 +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
1638 +
1639 +logical function func1 (vla)
1640 +  implicit none
1641 +  integer, allocatable :: vla (:, :)
1642 +  func1 = allocated(vla)
1643 +  vla(5,5) = 55               ! func1-vla-passed
1644 +  vla(7,7) = 77
1645 +  return                      ! func1-vla-modified
1646 +end function func1
1647 +
1648 +function func2(vla)
1649 +  implicit none
1650 +  integer :: vla (:)
1651 +  integer :: func2(size(vla))
1652 +  integer :: k
1653 +
1654 +  vla(1) = 1                    ! func2-vla-passed
1655 +  vla(2) = 2
1656 +  vla(4) = 4
1657 +  vla(8) = 8
1658 +
1659 +  func2 = vla
1660 +end function func2
1661 +
1662 +program vla_func
1663 +  implicit none
1664 +  interface
1665 +    logical function func1 (vla)
1666 +      integer :: vla (:, :)
1667 +    end function
1668 +  end interface
1669 +  interface
1670 +    function func2 (vla)
1671 +      integer :: vla (:)
1672 +      integer func2(size(vla))
1673 +    end function
1674 +  end interface
1675 +
1676 +  logical :: ret
1677 +  integer, allocatable :: vla1 (:, :)
1678 +  integer, allocatable :: vla2 (:)
1679 +  integer, allocatable :: vla3 (:)
1680 +
1681 +  ret = .FALSE.
1682 +
1683 +  allocate (vla1 (10,10))
1684 +  vla1(:,:) = 22
1685 +
1686 +  allocate (vla2 (10))
1687 +  vla2(:) = 44
1688 +
1689 +  ret = func1(vla1)
1690 +  vla3 = func2(vla2)          ! func1-returned
1691 +
1692 +  ret = .TRUE.                ! func2-returned
1693 +end program vla_func
1694 diff --git a/gdb/testsuite/gdb.fortran/vla-history.exp b/gdb/testsuite/gdb.fortran/vla-history.exp
1695 new file mode 100644
1696 index 0000000..170e1eb
1697 --- /dev/null
1698 +++ b/gdb/testsuite/gdb.fortran/vla-history.exp
1699 @@ -0,0 +1,62 @@
1700 +# Copyright 2014 Free Software Foundation, Inc.
1701 +
1702 +# This program is free software; you can redistribute it and/or modify
1703 +# it under the terms of the GNU General Public License as published by
1704 +# the Free Software Foundation; either version 3 of the License, or
1705 +# (at your option) any later version.
1706 +#
1707 +# This program is distributed in the hope that it will be useful,
1708 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1709 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1710 +# GNU General Public License for more details.
1711 +#
1712 +# You should have received a copy of the GNU General Public License
1713 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1714 +
1715 +standard_testfile "vla.f90"
1716 +
1717 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1718 +    {debug f90 quiet}] } {
1719 +    return -1
1720 +}
1721 +
1722 +if ![runto MAIN__] then {
1723 +    perror "couldn't run to breakpoint MAIN__"
1724 +    continue
1725 +}
1726 +
1727 +# Set some breakpoints and print complete vla.
1728 +gdb_breakpoint [gdb_get_line_number "vla1-init"]
1729 +gdb_continue_to_breakpoint "vla1-init"
1730 +gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1"
1731 +
1732 +gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
1733 +gdb_continue_to_breakpoint "vla2-allocated"
1734 +gdb_test "print vla1" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
1735 +  "print vla1 allocated"
1736 +gdb_test "print vla2" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
1737 +  "print vla2 allocated"
1738 +
1739 +gdb_breakpoint [gdb_get_line_number "vla1-filled"]
1740 +gdb_continue_to_breakpoint "vla1-filled"
1741 +gdb_test "print vla1" \
1742 +  " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" \
1743 +  "print vla1 filled"
1744 +
1745 +# Try to access history values for full vla prints.
1746 +gdb_test "print \$1" " = <not allocated>" "print \$1"
1747 +gdb_test "print \$2" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
1748 +  "print \$2"
1749 +gdb_test "print \$3" " = \\( *\\( *\\( *0, *0, *0,\[()0, .\]*\\)" \
1750 +  "print \$3"
1751 +gdb_test "print \$4" \
1752 +  " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" "print \$4"
1753 +
1754 +gdb_breakpoint [gdb_get_line_number "vla2-filled"]
1755 +gdb_continue_to_breakpoint "vla2-filled"
1756 +gdb_test "print vla2(1,43,20)" " = 1311" "print vla2(1,43,20)"
1757 +gdb_test "print vla1(1,3,8)" " = 1001" "print vla2(1,3,8)"
1758 +
1759 +# Try to access history values for vla values.
1760 +gdb_test "print \$9" " = 1311" "print \$9"
1761 +gdb_test "print \$10" " = 1001" "print \$10"
1762 diff --git a/gdb/testsuite/gdb.fortran/vla-ptype-sub.exp b/gdb/testsuite/gdb.fortran/vla-ptype-sub.exp
1763 new file mode 100644
1764 index 0000000..2ee2914
1765 --- /dev/null
1766 +++ b/gdb/testsuite/gdb.fortran/vla-ptype-sub.exp
1767 @@ -0,0 +1,87 @@
1768 +# Copyright 2014 Free Software Foundation, Inc.
1769 +
1770 +# This program is free software; you can redistribute it and/or modify
1771 +# it under the terms of the GNU General Public License as published by
1772 +# the Free Software Foundation; either version 3 of the License, or
1773 +# (at your option) any later version.
1774 +#
1775 +# This program is distributed in the hope that it will be useful,
1776 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1777 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1778 +# GNU General Public License for more details.
1779 +#
1780 +# You should have received a copy of the GNU General Public License
1781 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1782 +
1783 +standard_testfile "vla-sub.f90"
1784 +
1785 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1786 +    {debug f90 quiet}] } {
1787 +    return -1
1788 +}
1789 +
1790 +if ![runto MAIN__] then {
1791 +    perror "couldn't run to breakpoint MAIN__"
1792 +    continue
1793 +}
1794 +
1795 +# Pass fixed array to function and handle them as vla in function.
1796 +gdb_breakpoint [gdb_get_line_number "not-filled"]
1797 +gdb_continue_to_breakpoint "not-filled (1st)"
1798 +gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(42,42\\\)" \
1799 +  "ptype array1 (passed fixed)"
1800 +gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(42,42,42\\\)" \
1801 +  "ptype array2 (passed fixed)"
1802 +gdb_test "ptype array1(40, 10)" "type = integer\\\(kind=4\\\)" \
1803 +  "ptype array1(40, 10) (passed fixed)"
1804 +gdb_test "ptype array2(13, 11, 5)" "type = real\\\(kind=4\\\)" \
1805 +  "ptype array2(13, 11, 5) (passed fixed)"
1806 +
1807 +# Pass sub arrays to function and handle them as vla in function.
1808 +gdb_continue_to_breakpoint "not-filled (2nd)"
1809 +gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(6,6\\\)" \
1810 +  "ptype array1 (passed sub-array)"
1811 +gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(6,6,6\\\)" \
1812 +  "ptype array2 (passed sub-array)"
1813 +gdb_test "ptype array1(3, 3)" "type = integer\\\(kind=4\\\)" \
1814 +  "ptype array1(3, 3) (passed sub-array)"
1815 +gdb_test "ptype array2(4, 4, 4)" "type = real\\\(kind=4\\\)" \
1816 +  "ptype array2(4, 4, 4) (passed sub-array)"
1817 +
1818 +# Check ptype outside of bounds. This should not crash GDB.
1819 +gdb_test "ptype array1(100, 100)" "no such vector element" \
1820 +  "ptype array1(100, 100) subarray do not crash (passed sub-array)"
1821 +gdb_test "ptype array2(100, 100, 100)" "no such vector element" \
1822 +  "ptype array2(100, 100, 100) subarray do not crash (passed sub-array)"
1823 +
1824 +# Pass vla to function.
1825 +gdb_continue_to_breakpoint "not-filled (3rd)"
1826 +gdb_test "ptype array1" "type = integer\\\(kind=4\\\) \\\(20,20\\\)" \
1827 +  "ptype array1 (passed vla)"
1828 +gdb_test "ptype array2" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
1829 +  "ptype array2 (passed vla)"
1830 +gdb_test "ptype array1(3, 3)" "type = integer\\\(kind=4\\\)" \
1831 +  "ptype array1(3, 3) (passed vla)"
1832 +gdb_test "ptype array2(4, 4, 4)" "type = real\\\(kind=4\\\)" \
1833 +  "ptype array2(4, 4, 4) (passed vla)"
1834 +
1835 +# Check ptype outside of bounds. This should not crash GDB.
1836 +gdb_test "ptype array1(100, 100)" "no such vector element" \
1837 +  "ptype array1(100, 100) VLA do not crash (passed vla)"
1838 +gdb_test "ptype array2(100, 100, 100)" "no such vector element" \
1839 +  "ptype array2(100, 100, 100) VLA do not crash (passed vla)"
1840 +
1841 +# Pass fixed array to function and handle it as VLA of arbitrary length in
1842 +# function.
1843 +gdb_breakpoint [gdb_get_line_number "end-of-bar"]
1844 +gdb_continue_to_breakpoint "end-of-bar"
1845 +gdb_test "ptype array1" \
1846 +  "type = (PTR TO -> \\( )?integer(\\(kind=4\\)|\\*4) \\(\\*\\)\\)?" \
1847 +  "ptype array1 (arbitrary length)"
1848 +gdb_test "ptype array2" \
1849 +  "type = (PTR TO -> \\( )?integer(\\(kind=4\\)|\\*4) \\(4:9,10:\\*\\)\\)?" \
1850 +  "ptype array2 (arbitrary length)"
1851 +gdb_test "ptype array1(100)" "type = integer\\\(kind=4\\\)" \
1852 +  "ptype array1(100) (arbitrary length)"
1853 +gdb_test "ptype array2(4,100)" "type = integer\\\(kind=4\\\)" \
1854 +  "ptype array2(4,100) (arbitrary length)"
1855 diff --git a/gdb/testsuite/gdb.fortran/vla-ptype.exp b/gdb/testsuite/gdb.fortran/vla-ptype.exp
1856 new file mode 100644
1857 index 0000000..9267723
1858 --- /dev/null
1859 +++ b/gdb/testsuite/gdb.fortran/vla-ptype.exp
1860 @@ -0,0 +1,96 @@
1861 +# Copyright 2014 Free Software Foundation, Inc.
1862 +
1863 +# This program is free software; you can redistribute it and/or modify
1864 +# it under the terms of the GNU General Public License as published by
1865 +# the Free Software Foundation; either version 3 of the License, or
1866 +# (at your option) any later version.
1867 +#
1868 +# This program is distributed in the hope that it will be useful,
1869 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1870 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1871 +# GNU General Public License for more details.
1872 +#
1873 +# You should have received a copy of the GNU General Public License
1874 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1875 +
1876 +standard_testfile "vla.f90"
1877 +
1878 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1879 +    {debug f90 quiet}] } {
1880 +    return -1
1881 +}
1882 +
1883 +if ![runto MAIN__] then {
1884 +    perror "couldn't run to breakpoint MAIN__"
1885 +    continue
1886 +}
1887 +
1888 +# Check the ptype of various VLA states and pointer to VLA's.
1889 +gdb_breakpoint [gdb_get_line_number "vla1-init"]
1890 +gdb_continue_to_breakpoint "vla1-init"
1891 +gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not initialized"
1892 +gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not initialized"
1893 +gdb_test "ptype pvla" "type = <not associated>" "ptype pvla not initialized"
1894 +gdb_test "ptype vla1(3, 6, 9)" "no such vector element because not allocated" \
1895 +  "ptype vla1(3, 6, 9) not initialized"
1896 +gdb_test "ptype vla2(5, 45, 20)" \
1897 +  "no such vector element because not allocated" \
1898 +  "ptype vla1(5, 45, 20) not initialized"
1899 +
1900 +gdb_breakpoint [gdb_get_line_number "vla1-allocated"]
1901 +gdb_continue_to_breakpoint "vla1-allocated"
1902 +gdb_test "ptype vla1" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
1903 +  "ptype vla1 allocated"
1904 +
1905 +gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
1906 +gdb_continue_to_breakpoint "vla2-allocated"
1907 +gdb_test "ptype vla2" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
1908 +  "ptype vla2 allocated"
1909 +
1910 +gdb_breakpoint [gdb_get_line_number "vla1-filled"]
1911 +gdb_continue_to_breakpoint "vla1-filled"
1912 +gdb_test "ptype vla1" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
1913 +  "ptype vla1 filled"
1914 +gdb_test "ptype vla1(3, 6, 9)" "type = real\\\(kind=4\\\)" \
1915 +  "ptype vla1(3, 6, 9)"
1916 +
1917 +gdb_breakpoint [gdb_get_line_number "vla2-filled"]
1918 +gdb_continue_to_breakpoint "vla2-filled"
1919 +gdb_test "ptype vla2" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
1920 +  "ptype vla2 filled"
1921 +gdb_test "ptype vla2(5, 45, 20)" "type = real\\\(kind=4\\\)" \
1922 +  "ptype vla1(5, 45, 20) filled"
1923 +
1924 +gdb_breakpoint [gdb_get_line_number "pvla-associated"]
1925 +gdb_continue_to_breakpoint "pvla-associated"
1926 +gdb_test "ptype pvla" "type = real\\\(kind=4\\\) \\\(10,10,10\\\)" \
1927 +  "ptype pvla associated"
1928 +gdb_test "ptype pvla(3, 6, 9)" "type = real\\\(kind=4\\\)" \
1929 +  "ptype pvla(3, 6, 9)"
1930 +
1931 +gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
1932 +gdb_continue_to_breakpoint "pvla-re-associated"
1933 +gdb_test "ptype pvla" "type = real\\\(kind=4\\\) \\\(7,42:50,13:35\\\)" \
1934 +  "ptype pvla re-associated"
1935 +gdb_test "ptype vla2(5, 45, 20)" "type = real\\\(kind=4\\\)" \
1936 +  "ptype vla1(5, 45, 20) re-associated"
1937 +
1938 +gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
1939 +gdb_continue_to_breakpoint "pvla-deassociated"
1940 +gdb_test "ptype pvla" "type = <not associated>" "ptype pvla deassociated"
1941 +gdb_test "ptype pvla(5, 45, 20)" \
1942 +  "no such vector element because not associated" \
1943 +  "ptype pvla(5, 45, 20) not associated"
1944 +
1945 +gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
1946 +gdb_continue_to_breakpoint "vla1-deallocated"
1947 +gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not allocated"
1948 +gdb_test "ptype vla1(3, 6, 9)" "no such vector element because not allocated" \
1949 +  "ptype vla1(3, 6, 9) not allocated"
1950 +
1951 +gdb_breakpoint [gdb_get_line_number "vla2-deallocated"]
1952 +gdb_continue_to_breakpoint "vla2-deallocated"
1953 +gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not allocated"
1954 +gdb_test "ptype vla2(5, 45, 20)" \
1955 +  "no such vector element because not allocated" \
1956 +  "ptype vla2(5, 45, 20) not allocated"
1957 diff --git a/gdb/testsuite/gdb.fortran/vla-sizeof.exp b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
1958 new file mode 100644
1959 index 0000000..6053c17
1960 --- /dev/null
1961 +++ b/gdb/testsuite/gdb.fortran/vla-sizeof.exp
1962 @@ -0,0 +1,46 @@
1963 +# Copyright 2014 Free Software Foundation, Inc.
1964 +
1965 +# This program is free software; you can redistribute it and/or modify
1966 +# it under the terms of the GNU General Public License as published by
1967 +# the Free Software Foundation; either version 3 of the License, or
1968 +# (at your option) any later version.
1969 +#
1970 +# This program is distributed in the hope that it will be useful,
1971 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1972 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
1973 +# GNU General Public License for more details.
1974 +#
1975 +# You should have received a copy of the GNU General Public License
1976 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
1977 +
1978 +standard_testfile "vla.f90"
1979 +
1980 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1981 +    {debug f90 quiet}] } {
1982 +    return -1
1983 +}
1984 +
1985 +if ![runto MAIN__] then {
1986 +    perror "couldn't run to breakpoint MAIN__"
1987 +    continue
1988 +}
1989 +
1990 +# Try to access values in non allocated VLA
1991 +gdb_breakpoint [gdb_get_line_number "vla1-init"]
1992 +gdb_continue_to_breakpoint "vla1-init"
1993 +gdb_test "print sizeof(vla1)" " = 0" "print sizeof non-allocated vla1"
1994 +
1995 +# Try to access value in allocated VLA
1996 +gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
1997 +gdb_continue_to_breakpoint "vla2-allocated"
1998 +gdb_test "print sizeof(vla1)" " = 4000" "print sizeof allocated vla1"
1999 +
2000 +# Try to access values in undefined pointer to VLA (dangling)
2001 +gdb_breakpoint [gdb_get_line_number "vla1-filled"]
2002 +gdb_continue_to_breakpoint "vla1-filled"
2003 +gdb_test "print sizeof(pvla)" " = 0" "print sizeof non-associated pvla"
2004 +
2005 +# Try to access values in pointer to VLA and compare them
2006 +gdb_breakpoint [gdb_get_line_number "pvla-associated"]
2007 +gdb_continue_to_breakpoint "pvla-associated"
2008 +gdb_test "print sizeof(pvla)" " = 4000" "print sizeof associated pvla"
2009 diff --git a/gdb/testsuite/gdb.fortran/vla-stride.exp b/gdb/testsuite/gdb.fortran/vla-stride.exp
2010 new file mode 100644
2011 index 0000000..35f585d
2012 --- /dev/null
2013 +++ b/gdb/testsuite/gdb.fortran/vla-stride.exp
2014 @@ -0,0 +1,44 @@
2015 +# Copyright 2014 Free Software Foundation, Inc.
2016 +
2017 +# This program is free software; you can redistribute it and/or modify
2018 +# it under the terms of the GNU General Public License as published by
2019 +# the Free Software Foundation; either version 3 of the License, or
2020 +# (at your option) any later version.
2021 +#
2022 +# This program is distributed in the hope that it will be useful,
2023 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
2024 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2025 +# GNU General Public License for more details.
2026 +#
2027 +# You should have received a copy of the GNU General Public License
2028 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
2029 +
2030 +standard_testfile ".f90"
2031 +
2032 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
2033 +    {debug f90 quiet}] } {
2034 +    return -1
2035 +}
2036 +
2037 +if ![runto MAIN__] then {
2038 +    perror "couldn't run to breakpoint MAIN__"
2039 +    continue
2040 +}
2041 +
2042 +gdb_breakpoint [gdb_get_line_number "re-reverse-elements"]
2043 +gdb_continue_to_breakpoint "re-reverse-elements"
2044 +gdb_test "print pvla" " = \\\(1, 2, 3, 4, 5, 6, 7, 8, 9, 10\\\)" \
2045 +  "print re-reverse-elements"
2046 +gdb_test "print pvla(1)" " = 1" "print first re-reverse-element"
2047 +gdb_test "print pvla(10)" " = 10" "print last re-reverse-element"
2048 +
2049 +gdb_breakpoint [gdb_get_line_number "odd-elements"]
2050 +gdb_continue_to_breakpoint "odd-elements"
2051 +gdb_test "print pvla" " = \\\(1, 3, 5, 7, 9\\\)" "print odd-elements"
2052 +gdb_test "print pvla(1)" " = 1" "print first odd-element"
2053 +gdb_test "print pvla(5)" " = 9" "print last odd-element"
2054 +
2055 +gdb_breakpoint [gdb_get_line_number "single-element"]
2056 +gdb_continue_to_breakpoint "single-element"
2057 +gdb_test "print pvla" " = \\\(5\\\)" "print single-element"
2058 +gdb_test "print pvla(1)" " = 5" "print one single-element"
2059 diff --git a/gdb/testsuite/gdb.fortran/vla-stride.f90 b/gdb/testsuite/gdb.fortran/vla-stride.f90
2060 new file mode 100644
2061 index 0000000..6aa4f2b
2062 --- /dev/null
2063 +++ b/gdb/testsuite/gdb.fortran/vla-stride.f90
2064 @@ -0,0 +1,30 @@
2065 +! Copyright 2014 Free Software Foundation, Inc.
2066 +!
2067 +! This program is free software; you can redistribute it and/or modify
2068 +! it under the terms of the GNU General Public License as published by
2069 +! the Free Software Foundation; either version 2 of the License, or
2070 +! (at your option) any later version.
2071 +!
2072 +! This program is distributed in the hope that it will be useful,
2073 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
2074 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2075 +! GNU General Public License for more details.
2076 +!
2077 +! You should have received a copy of the GNU General Public License
2078 +! along with this program; if not, write to the Free Software
2079 +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
2080 +
2081 +program vla_stride
2082 +  integer, target, allocatable :: vla (:)
2083 +  integer, pointer :: pvla (:)
2084 +
2085 +  allocate(vla(10))
2086 +  vla = (/ (I, I = 1,10) /)
2087 +
2088 +  pvla => vla(10:1:-1)
2089 +  pvla => pvla(10:1:-1)
2090 +  pvla => vla(1:10:2)   ! re-reverse-elements
2091 +  pvla => vla(5:4:-2)   ! odd-elements
2092 +
2093 +  pvla => null()        ! single-element
2094 +end program vla_stride
2095 diff --git a/gdb/testsuite/gdb.fortran/vla-strings.exp b/gdb/testsuite/gdb.fortran/vla-strings.exp
2096 new file mode 100644
2097 index 0000000..7fc1734
2098 --- /dev/null
2099 +++ b/gdb/testsuite/gdb.fortran/vla-strings.exp
2100 @@ -0,0 +1,104 @@
2101 +# Copyright 2014 Free Software Foundation, Inc.
2102 +
2103 +# This program is free software; you can redistribute it and/or modify
2104 +# it under the terms of the GNU General Public License as published by
2105 +# the Free Software Foundation; either version 3 of the License, or
2106 +# (at your option) any later version.
2107 +#
2108 +# This program is distributed in the hope that it will be useful,
2109 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
2110 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2111 +# GNU General Public License for more details.
2112 +#
2113 +# You should have received a copy of the GNU General Public License
2114 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
2115 +
2116 +standard_testfile ".f90"
2117 +
2118 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
2119 +    {debug f90 quiet}] } {
2120 +    return -1
2121 +}
2122 +
2123 +# check that all fortran standard datatypes will be
2124 +# handled correctly when using as VLA's
2125 +
2126 +if ![runto MAIN__] then {
2127 +    perror "couldn't run to breakpoint MAIN__"
2128 +    continue
2129 +}
2130 +
2131 +gdb_breakpoint [gdb_get_line_number "var_char-allocated-1"]
2132 +gdb_continue_to_breakpoint "var_char-allocated-1"
2133 +gdb_test "print var_char" \
2134 +  " = \\(PTR TO -> \\( character\\*10 \\)\\) ${hex}" \
2135 +  "print var_char after allocated first time"
2136 +gdb_test "print *var_char" \
2137 +  " = '\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000\\\\000'" \
2138 +  "print *var_char after allocated first time"
2139 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*10 \\)" \
2140 +  "whatis var_char first time"
2141 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*10 \\)" \
2142 +  "ptype var_char first time"
2143 +gdb_test "next" "\\d+.*var_char = 'foo'.*" \
2144 +  "next to allocation status of var_char"
2145 +gdb_test "print l" " = .TRUE." "print allocation status first time"
2146 +
2147 +gdb_breakpoint [gdb_get_line_number "var_char-filled-1"]
2148 +gdb_continue_to_breakpoint "var_char-filled-1"
2149 +gdb_test "print var_char" \
2150 +  " = \\(PTR TO -> \\( character\\*3 \\)\\) ${hex}" \
2151 +  "print var_char after filled first time"
2152 +gdb_test "print *var_char" " = 'foo'" \
2153 +  "print *var_char after filled first time"
2154 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*3 \\)" \
2155 +  "whatis var_char after filled first time"
2156 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*3 \\)" \
2157 +  "ptype var_char after filled first time"
2158 +gdb_test "print var_char(1)" " = 102 'f'" "print var_char(1)"
2159 +gdb_test "print var_char(3)" " = 111 'o'" "print var_char(3)"
2160 +
2161 +gdb_breakpoint [gdb_get_line_number "var_char-filled-2"]
2162 +gdb_continue_to_breakpoint "var_char-filled-2"
2163 +gdb_test "print var_char" \
2164 +  " = \\(PTR TO -> \\( character\\*6 \\)\\) ${hex}" \
2165 +  "print var_char after allocated second time"
2166 +gdb_test "print *var_char" " = 'foobar'" \
2167 +  "print *var_char after allocated second time"
2168 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*6 \\)" \
2169 +  "whatis var_char second time"
2170 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*6 \\)" \
2171 +  "ptype var_char second time"
2172 +
2173 +gdb_breakpoint [gdb_get_line_number "var_char-empty"]
2174 +gdb_continue_to_breakpoint "var_char-empty"
2175 +gdb_test "print var_char" \
2176 +  " = \\(PTR TO -> \\( character\\*0 \\)\\) ${hex}" \
2177 +  "print var_char after set empty"
2178 +gdb_test "print *var_char" " = \"\"" "print *var_char after set empty"
2179 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*0 \\)" \
2180 +  "whatis var_char after set empty"
2181 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*0 \\)" \
2182 +  "ptype var_char after set empty"
2183 +
2184 +gdb_breakpoint [gdb_get_line_number "var_char-allocated-3"]
2185 +gdb_continue_to_breakpoint "var_char-allocated-3"
2186 +gdb_test "print var_char" \
2187 +  " = \\(PTR TO -> \\( character\\*21 \\)\\) ${hex}" \
2188 +  "print var_char after allocated third time"
2189 +gdb_test "whatis var_char" "type = PTR TO -> \\( character\\*21 \\)" \
2190 +  "whatis var_char after allocated third time"
2191 +gdb_test "ptype var_char" "type = PTR TO -> \\( character\\*21 \\)" \
2192 +  "ptype var_char after allocated third time"
2193 +
2194 +gdb_breakpoint [gdb_get_line_number "var_char_p-associated"]
2195 +gdb_continue_to_breakpoint "var_char_p-associated"
2196 +gdb_test "print var_char_p" \
2197 +  " = \\(PTR TO -> \\( character\\*7 \\)\\) ${hex}" \
2198 +  "print var_char_p after associated"
2199 +gdb_test "print *var_char_p" " = 'johndoe'" \
2200 +  "print *var_char_ after associated"
2201 +gdb_test "whatis var_char_p" "type = PTR TO -> \\( character\\*7 \\)" \
2202 +  "whatis var_char_p after associated"
2203 +gdb_test "ptype var_char_p" "type = PTR TO -> \\( character\\*7 \\)" \
2204 +  "ptype var_char_p after associated"
2205 diff --git a/gdb/testsuite/gdb.fortran/vla-strings.f90 b/gdb/testsuite/gdb.fortran/vla-strings.f90
2206 new file mode 100644
2207 index 0000000..0a1d522
2208 --- /dev/null
2209 +++ b/gdb/testsuite/gdb.fortran/vla-strings.f90
2210 @@ -0,0 +1,40 @@
2211 +! Copyright 2014 Free Software Foundation, Inc.
2212 +!
2213 +! This program is free software; you can redistribute it and/or modify
2214 +! it under the terms of the GNU General Public License as published by
2215 +! the Free Software Foundation; either version 2 of the License, or
2216 +! (at your option) any later version.
2217 +!
2218 +! This program is distributed in the hope that it will be useful,
2219 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
2220 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2221 +! GNU General Public License for more details.
2222 +!
2223 +! You should have received a copy of the GNU General Public License
2224 +! along with this program; if not, write to the Free Software
2225 +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
2226 +
2227 +program vla_strings
2228 +  character(len=:), target, allocatable   :: var_char
2229 +  character(len=:), pointer               :: var_char_p
2230 +  logical                                 :: l
2231 +
2232 +  allocate(character(len=10) :: var_char)
2233 +  l = allocated(var_char)                 ! var_char-allocated-1
2234 +  var_char = 'foo'
2235 +  deallocate(var_char)                    ! var_char-filled-1
2236 +  l = allocated(var_char)                 ! var_char-deallocated
2237 +  allocate(character(len=42) :: var_char)
2238 +  l = allocated(var_char)
2239 +  var_char = 'foobar'
2240 +  var_char = ''                           ! var_char-filled-2
2241 +  var_char = 'bar'                        ! var_char-empty
2242 +  deallocate(var_char)
2243 +  allocate(character(len=21) :: var_char)
2244 +  l = allocated(var_char)                 ! var_char-allocated-3
2245 +  var_char = 'johndoe'
2246 +  var_char_p => var_char
2247 +  l = associated(var_char_p)              ! var_char_p-associated
2248 +  var_char_p => null()
2249 +  l = associated(var_char_p)              ! var_char_p-not-associated
2250 +end program vla_strings
2251 diff --git a/gdb/testsuite/gdb.fortran/vla-sub.f90 b/gdb/testsuite/gdb.fortran/vla-sub.f90
2252 new file mode 100644
2253 index 0000000..8c2c9ff
2254 --- /dev/null
2255 +++ b/gdb/testsuite/gdb.fortran/vla-sub.f90
2256 @@ -0,0 +1,82 @@
2257 +! Copyright 2014 Free Software Foundation, Inc.
2258 +!
2259 +! This program is free software; you can redistribute it and/or modify
2260 +! it under the terms of the GNU General Public License as published by
2261 +! the Free Software Foundation; either version 2 of the License, or
2262 +! (at your option) any later version.
2263 +!
2264 +! This program is distributed in the hope that it will be useful,
2265 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
2266 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2267 +! GNU General Public License for more details.
2268 +!
2269 +! You should have received a copy of the GNU General Public License
2270 +! along with this program; if not, write to the Free Software
2271 +! Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
2272 +!
2273 +! Original file written by Jakub Jelinek <jakub@redhat.com> and
2274 +! Jan Kratochvil <jan.kratochvil@redhat.com>.
2275 +! Modified for the GDB testcases by Keven Boell <keven.boell@intel.com>.
2276 +
2277 +subroutine foo (array1, array2)
2278 +  integer :: array1 (:, :)
2279 +  real    :: array2 (:, :, :)
2280 +
2281 +  array1(:,:) = 5                       ! not-filled
2282 +  array1(1, 1) = 30
2283 +
2284 +  array2(:,:,:) = 6                     ! array1-filled
2285 +  array2(:,:,:) = 3
2286 +  array2(1,1,1) = 30
2287 +  array2(3,3,3) = 90                    ! array2-almost-filled
2288 +end subroutine
2289 +
2290 +subroutine bar (array1, array2)
2291 +  integer :: array1 (*)
2292 +  integer :: array2 (4:9, 10:*)
2293 +
2294 +  array1(5:10) = 1311
2295 +  array1(7) = 1
2296 +  array1(100) = 100
2297 +  array2(4,10) = array1(7)
2298 +  array2(4,100) = array1(7)
2299 +  return                                ! end-of-bar
2300 +end subroutine
2301 +
2302 +program vla_sub
2303 +  interface
2304 +    subroutine foo (array1, array2)
2305 +      integer :: array1 (:, :)
2306 +      real :: array2 (:, :, :)
2307 +    end subroutine
2308 +  end interface
2309 +  interface
2310 +    subroutine bar (array1, array2)
2311 +      integer :: array1 (*)
2312 +      integer :: array2 (4:9, 10:*)
2313 +    end subroutine
2314 +  end interface
2315 +
2316 +  real, allocatable :: vla1 (:, :, :)
2317 +  integer, allocatable :: vla2 (:, :)
2318 +
2319 +  ! used for subroutine
2320 +  integer :: sub_arr1(42, 42)
2321 +  real    :: sub_arr2(42, 42, 42)
2322 +  integer :: sub_arr3(42)
2323 +
2324 +  sub_arr1(:,:) = 1                   ! vla2-deallocated
2325 +  sub_arr2(:,:,:) = 2
2326 +  sub_arr3(:) = 3
2327 +
2328 +  call foo(sub_arr1, sub_arr2)
2329 +  call foo(sub_arr1(5:10, 5:10), sub_arr2(10:15,10:15,10:15))
2330 +
2331 +  allocate (vla1 (10,10,10))
2332 +  allocate (vla2 (20,20))
2333 +  vla1(:,:,:) = 1311
2334 +  vla2(:,:) = 42
2335 +  call foo(vla2, vla1)
2336 +
2337 +  call bar(sub_arr3, sub_arr1)
2338 +end program vla_sub
2339 diff --git a/gdb/testsuite/gdb.fortran/vla-value-sub-arbitrary.exp b/gdb/testsuite/gdb.fortran/vla-value-sub-arbitrary.exp
2340 new file mode 100644
2341 index 0000000..fd11adb
2342 --- /dev/null
2343 +++ b/gdb/testsuite/gdb.fortran/vla-value-sub-arbitrary.exp
2344 @@ -0,0 +1,35 @@
2345 +# Copyright 2014 Free Software Foundation, Inc.
2346 +
2347 +# This program is free software; you can redistribute it and/or modify
2348 +# it under the terms of the GNU General Public License as published by
2349 +# the Free Software Foundation; either version 3 of the License, or
2350 +# (at your option) any later version.
2351 +#
2352 +# This program is distributed in the hope that it will be useful,
2353 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
2354 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2355 +# GNU General Public License for more details.
2356 +#
2357 +# You should have received a copy of the GNU General Public License
2358 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
2359 +
2360 +standard_testfile "vla-sub.f90"
2361 +
2362 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
2363 +    {debug f90 quiet}] } {
2364 +    return -1
2365 +}
2366 +
2367 +if ![runto MAIN__] then {
2368 +    perror "couldn't run to breakpoint MAIN__"
2369 +    continue
2370 +}
2371 +
2372 +# Check VLA with arbitary length and check that elements outside of
2373 +# bounds of the passed VLA can be accessed correctly.
2374 +gdb_breakpoint [gdb_get_line_number "end-of-bar"]
2375 +gdb_continue_to_breakpoint "end-of-bar"
2376 +gdb_test "p array1(42)" " = 3" "print arbitary array1(42)"
2377 +gdb_test "p array1(100)" " = 100" "print arbitary array1(100)"
2378 +gdb_test "p array2(4,10)" " = 1" "print arbitary array2(4,10)"
2379 +gdb_test "p array2(4,100)" " = 1" "print arbitary array2(4,100)"
2380 diff --git a/gdb/testsuite/gdb.fortran/vla-value-sub-finish.exp b/gdb/testsuite/gdb.fortran/vla-value-sub-finish.exp
2381 new file mode 100644
2382 index 0000000..a163617
2383 --- /dev/null
2384 +++ b/gdb/testsuite/gdb.fortran/vla-value-sub-finish.exp
2385 @@ -0,0 +1,49 @@
2386 +# Copyright 2014 Free Software Foundation, Inc.
2387 +
2388 +# This program is free software; you can redistribute it and/or modify
2389 +# it under the terms of the GNU General Public License as published by
2390 +# the Free Software Foundation; either version 3 of the License, or
2391 +# (at your option) any later version.
2392 +#
2393 +# This program is distributed in the hope that it will be useful,
2394 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
2395 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2396 +# GNU General Public License for more details.
2397 +#
2398 +# You should have received a copy of the GNU General Public License
2399 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
2400 +
2401 +standard_testfile "vla-sub.f90"
2402 +
2403 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
2404 +    {debug f90 quiet}] } {
2405 +    return -1
2406 +}
2407 +
2408 +if ![runto MAIN__] then {
2409 +    perror "couldn't run to breakpoint MAIN__"
2410 +    continue
2411 +}
2412 +
2413 +# "up" works with GCC but other Fortran compilers may copy the values into the
2414 +# outer function only on the exit of the inner function.
2415 +# We need both variants as depending on the arch we optionally may still be
2416 +# executing the caller line or not after `finish'.
2417 +
2418 +gdb_breakpoint [gdb_get_line_number "array2-almost-filled"]
2419 +gdb_continue_to_breakpoint "array2-almost-filled"
2420 +gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
2421 +  "print array2 in foo after it was filled"
2422 +gdb_test "print array2(2,1,1)=20" " = 20" \
2423 +  "set array(2,2,2) to 20 in subroutine"
2424 +gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
2425 +  "print array2 in foo after it was mofified in debugger"
2426 +
2427 +gdb_test "finish" \
2428 +  ".*foo\\\(sub_arr1\\\(5:10, 5:10\\\), sub_arr2\\\(10:15,10:15,10:15\\\)\\\)" \
2429 +  "finish function"
2430 +gdb_test "p sub_arr1(5, 7)" " = 5" "sub_arr1(5, 7) after finish"
2431 +gdb_test "p sub_arr1(1, 1)" " = 30" "sub_arr1(1, 1) after finish"
2432 +gdb_test "p sub_arr2(1, 1, 1)" " = 30" "sub_arr2(1, 1, 1) after finish"
2433 +gdb_test "p sub_arr2(2, 1, 1)" " = 20" "sub_arr2(2, 1, 1) after finish"
2434 +
2435 diff --git a/gdb/testsuite/gdb.fortran/vla-value-sub.exp b/gdb/testsuite/gdb.fortran/vla-value-sub.exp
2436 new file mode 100644
2437 index 0000000..848f9d7
2438 --- /dev/null
2439 +++ b/gdb/testsuite/gdb.fortran/vla-value-sub.exp
2440 @@ -0,0 +1,90 @@
2441 +# Copyright 2014 Free Software Foundation, Inc.
2442 +
2443 +# This program is free software; you can redistribute it and/or modify
2444 +# it under the terms of the GNU General Public License as published by
2445 +# the Free Software Foundation; either version 3 of the License, or
2446 +# (at your option) any later version.
2447 +#
2448 +# This program is distributed in the hope that it will be useful,
2449 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
2450 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2451 +# GNU General Public License for more details.
2452 +#
2453 +# You should have received a copy of the GNU General Public License
2454 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
2455 +
2456 +standard_testfile "vla-sub.f90"
2457 +
2458 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
2459 +    {debug f90 quiet}] } {
2460 +    return -1
2461 +}
2462 +
2463 +if ![runto MAIN__] then {
2464 +    perror "couldn't run to breakpoint MAIN__"
2465 +    continue
2466 +}
2467 +
2468 +# Check the values of VLA's in subroutine can be evaluated correctly
2469 +
2470 +# Try to access values from a fixed array handled as VLA in subroutine.
2471 +gdb_breakpoint [gdb_get_line_number "not-filled"]
2472 +gdb_continue_to_breakpoint "not-filled (1st)"
2473 +gdb_test "print array1" " = \\(\[()1, .\]*\\)" \
2474 +  "print passed array1 in foo (passed fixed array)"
2475 +
2476 +gdb_breakpoint [gdb_get_line_number "array1-filled"]
2477 +gdb_continue_to_breakpoint "array1-filled (1st)"
2478 +gdb_test "print array1(5, 7)" " = 5" \
2479 +  "print array1(5, 7) after filled in foo (passed fixed array)"
2480 +gdb_test "print array1(1, 1)" " = 30" \
2481 +  "print array1(1, 1) after filled in foo (passed fixed array)"
2482 +
2483 +gdb_breakpoint [gdb_get_line_number "array2-almost-filled"]
2484 +gdb_continue_to_breakpoint "array2-almost-filled (1st)"
2485 +gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
2486 +  "print array2 in foo after it was filled (passed fixed array)"
2487 +gdb_test "print array2(2,1,1)=20" " = 20" \
2488 +  "set array(2,2,2) to 20 in subroutine (passed fixed array)"
2489 +gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
2490 +  "print array2 in foo after it was mofified in debugger (passed fixed array)"
2491 +
2492 +
2493 +# Try to access values from a fixed sub-array handled as VLA in subroutine.
2494 +gdb_continue_to_breakpoint "not-filled (2nd)"
2495 +gdb_test "print array1" " = \\(\[()5, .\]*\\)" \
2496 +  "print passed array1 in foo (passed sub-array)"
2497 +
2498 +gdb_continue_to_breakpoint "array1-filled (2nd)"
2499 +gdb_test "print array1(5, 5)" " = 5" \
2500 +  "print array1(5, 5) after filled in foo (passed sub-array)"
2501 +gdb_test "print array1(1, 1)" " = 30" \
2502 +  "print array1(1, 1) after filled in foo (passed sub-array)"
2503 +
2504 +gdb_continue_to_breakpoint "array2-almost-filled (2nd)"
2505 +gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
2506 +  "print array2 in foo after it was filled (passed sub-array)"
2507 +gdb_test "print array2(2,1,1)=20" " = 20" \
2508 +  "set array(2,2,2) to 20 in subroutine (passed sub-array)"
2509 +gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
2510 +  "print array2 in foo after it was mofified in debugger (passed sub-array)"
2511 +
2512 +
2513 +# Try to access values from a VLA passed to subroutine.
2514 +gdb_continue_to_breakpoint "not-filled (3rd)"
2515 +gdb_test "print array1" " = \\(\[()42, .\]*\\)" \
2516 +  "print passed array1 in foo (passed vla)"
2517 +
2518 +gdb_continue_to_breakpoint "array1-filled (3rd)"
2519 +gdb_test "print array1(5, 5)" " = 5" \
2520 +  "print array1(5, 5) after filled in foo (passed vla)"
2521 +gdb_test "print array1(1, 1)" " = 30" \
2522 +  "print array1(1, 1) after filled in foo (passed vla)"
2523 +
2524 +gdb_continue_to_breakpoint "array2-almost-filled (3rd)"
2525 +gdb_test "print array2" " = \\( *\\( *\\( *30, *3, *3,\[()3, .\]*\\)" \
2526 +  "print array2 in foo after it was filled (passed vla)"
2527 +gdb_test "print array2(2,1,1)=20" " = 20" \
2528 +  "set array(2,2,2) to 20 in subroutine (passed vla)"
2529 +gdb_test "print array2" " = \\( *\\( *\\( *30, *20, *3,\[()3, .\]*\\)" \
2530 +  "print array2 in foo after it was mofified in debugger (passed vla)"
2531 diff --git a/gdb/testsuite/gdb.fortran/vla-value.exp b/gdb/testsuite/gdb.fortran/vla-value.exp
2532 new file mode 100644
2533 index 0000000..d7b8a1e
2534 --- /dev/null
2535 +++ b/gdb/testsuite/gdb.fortran/vla-value.exp
2536 @@ -0,0 +1,148 @@
2537 +# Copyright 2014 Free Software Foundation, Inc.
2538 +
2539 +# This program is free software; you can redistribute it and/or modify
2540 +# it under the terms of the GNU General Public License as published by
2541 +# the Free Software Foundation; either version 3 of the License, or
2542 +# (at your option) any later version.
2543 +#
2544 +# This program is distributed in the hope that it will be useful,
2545 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
2546 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2547 +# GNU General Public License for more details.
2548 +#
2549 +# You should have received a copy of the GNU General Public License
2550 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
2551 +
2552 +standard_testfile "vla.f90"
2553 +
2554 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
2555 +     {debug f90 quiet}] } {
2556 +    return -1
2557 +}
2558 +
2559 +if ![runto MAIN__] then {
2560 +    perror "couldn't run to breakpoint MAIN__"
2561 +    continue
2562 +}
2563 +
2564 +# Try to access values in non allocated VLA
2565 +gdb_breakpoint [gdb_get_line_number "vla1-init"]
2566 +gdb_continue_to_breakpoint "vla1-init"
2567 +gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1"
2568 +gdb_test "print &vla1" \
2569 +  " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(<not allocated>\\\)\\\)\\\) $hex" \
2570 +  "print non-allocated &vla1"
2571 +gdb_test "print vla1(1,1,1)" "no such vector element because not allocated" \
2572 +  "print member in non-allocated vla1 (1)"
2573 +gdb_test "print vla1(101,202,303)" \
2574 +  "no such vector element because not allocated" \
2575 +  "print member in non-allocated vla1 (2)"
2576 +gdb_test "print vla1(5,2,18)=1" "no such vector element because not allocated" \
2577 +  "set member in non-allocated vla1"
2578 +
2579 +# Try to access value in allocated VLA
2580 +gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
2581 +gdb_continue_to_breakpoint "vla2-allocated"
2582 +gdb_test "next" "\\d+(\\t|\\s)+vla1\\\(3, 6, 9\\\) = 42" \
2583 +  "step over value assignment of vla1"
2584 +gdb_test "print &vla1" \
2585 +  " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(10,10,10\\\)\\\)\\\) $hex" \
2586 +  "print allocated &vla1"
2587 +gdb_test "print vla1(3, 6, 9)" " = 1311" "print allocated vla1(3,6,9)"
2588 +gdb_test "print vla1(1, 3, 8)" " = 1311" "print allocated vla1(1,3,8)"
2589 +gdb_test "print vla1(9, 9, 9) = 999" " = 999" \
2590 +  "print allocated vla1(9,9,9)=1"
2591 +
2592 +# Try to access values in allocated VLA after specific assignment
2593 +gdb_breakpoint [gdb_get_line_number "vla1-filled"]
2594 +gdb_continue_to_breakpoint "vla1-filled"
2595 +gdb_test "print vla1(3, 6, 9)" " = 42" \
2596 +  "print allocated vla1(3,6,9) after specific assignment (filled)"
2597 +gdb_test "print vla1(1, 3, 8)" " = 1001" \
2598 +  "print allocated vla1(1,3,8) after specific assignment (filled)"
2599 +gdb_test "print vla1(9, 9, 9)" " = 999" \
2600 +  "print allocated vla1(9,9,9) after assignment in debugger (filled)"
2601 +
2602 +# Try to access values in undefined pointer to VLA (dangling)
2603 +gdb_test "print pvla" " = <not associated>" "print undefined pvla"
2604 +gdb_test "print &pvla" \
2605 +  " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(<not associated>\\\)\\\)\\\) $hex" \
2606 +  "print non-associated &pvla"
2607 +gdb_test "print pvla(1, 3, 8)" "no such vector element because not associated" \
2608 +  "print undefined pvla(1,3,8)"
2609 +
2610 +# Try to access values in pointer to VLA and compare them
2611 +gdb_breakpoint [gdb_get_line_number "pvla-associated"]
2612 +gdb_continue_to_breakpoint "pvla-associated"
2613 +gdb_test "print &pvla" \
2614 +  " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(10,10,10\\\)\\\)\\\) $hex" \
2615 +  "print associated &pvla"
2616 +gdb_test "print pvla(3, 6, 9)" " = 42" "print associated pvla(3,6,9)"
2617 +gdb_test "print pvla(1, 3, 8)" " = 1001" "print associated pvla(1,3,8)"
2618 +gdb_test "print pvla(9, 9, 9)" " = 999" "print associated pvla(9,9,9)"
2619 +
2620 +# Fill values to VLA using pointer and check
2621 +gdb_breakpoint [gdb_get_line_number "pvla-re-associated"]
2622 +gdb_continue_to_breakpoint "pvla-re-associated"
2623 +gdb_test "print pvla(5, 45, 20)" \
2624 +  " = 1" "print pvla(5, 45, 20) after filled using pointer"
2625 +gdb_test "print vla2(5, 45, 20)" \
2626 +  " = 1" "print vla2(5, 45, 20) after filled using pointer"
2627 +gdb_test "print pvla(7, 45, 14)" " = 2" \
2628 +  "print pvla(7, 45, 14) after filled using pointer"
2629 +gdb_test "print vla2(7, 45, 14)" " = 2" \
2630 +  "print vla2(7, 45, 14) after filled using pointer"
2631 +
2632 +# Try to access values of deassociated VLA pointer
2633 +gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
2634 +gdb_continue_to_breakpoint "pvla-deassociated"
2635 +gdb_test "print pvla(5, 45, 20)" \
2636 +  "no such vector element because not associated" \
2637 +  "print pvla(5, 45, 20) after deassociated"
2638 +gdb_test "print pvla(7, 45, 14)" \
2639 +  "no such vector element because not associated" \
2640 +  "print pvla(7, 45, 14) after dissasociated"
2641 +gdb_test "print pvla" " = <not associated>" \
2642 +  "print vla1 after deassociated"
2643 +
2644 +# Try to access values of deallocated VLA
2645 +gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
2646 +gdb_continue_to_breakpoint "vla1-deallocated"
2647 +gdb_test "print vla1(3, 6, 9)" "no such vector element because not allocated" \
2648 +  "print allocated vla1(3,6,9) after specific assignment (deallocated)"
2649 +gdb_test "print vla1(1, 3, 8)" "no such vector element because not allocated" \
2650 +  "print allocated vla1(1,3,8) after specific assignment (deallocated)"
2651 +gdb_test "print vla1(9, 9, 9)" "no such vector element because not allocated" \
2652 +  "print allocated vla1(9,9,9) after assignment in debugger (deallocated)"
2653 +
2654 +
2655 +# Try to assign VLA to user variable
2656 +clean_restart ${testfile}
2657 +
2658 +if ![runto MAIN__] then {
2659 +    perror "couldn't run to breakpoint MAIN__"
2660 +    continue
2661 +}
2662 +gdb_breakpoint [gdb_get_line_number "vla2-allocated"]
2663 +gdb_continue_to_breakpoint "vla2-allocated"
2664 +gdb_test "next" "\\d+.*vla1\\(3, 6, 9\\) = 42" "next (1)"
2665 +
2666 +gdb_test_no_output "set \$myvar = vla1" "set \$myvar = vla1"
2667 +gdb_test "print \$myvar" \
2668 +  " = \\( *\\( *\\( *1311, *1311, *1311,\[()1311, .\]*\\)" \
2669 +  "print \$myvar set to vla1"
2670 +
2671 +gdb_test "next" "\\d+.*vla1\\(1, 3, 8\\) = 1001" "next (2)"
2672 +gdb_test "print \$myvar(3,6,9)" " = 1311" "print \$myvar(3,6,9)"
2673 +
2674 +gdb_breakpoint [gdb_get_line_number "pvla-associated"]
2675 +gdb_continue_to_breakpoint "pvla-associated"
2676 +gdb_test_no_output "set \$mypvar = pvla" "set \$mypvar = pvla"
2677 +gdb_test "print \$mypvar(1,3,8)" " = 1001" "print \$mypvar(1,3,8)"
2678 +
2679 +# deallocate pointer and make sure user defined variable still has the
2680 +# right value.
2681 +gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
2682 +gdb_continue_to_breakpoint "pvla-deassociated"
2683 +gdb_test "print \$mypvar(1,3,8)" " = 1001" \
2684 +  "print \$mypvar(1,3,8) after deallocated"
2685 diff --git a/gdb/testsuite/gdb.fortran/vla.f90 b/gdb/testsuite/gdb.fortran/vla.f90
2686 new file mode 100644
2687 index 0000000..73425f3
2688 --- /dev/null
2689 +++ b/gdb/testsuite/gdb.fortran/vla.f90
2690 @@ -0,0 +1,56 @@
2691 +! Copyright 2014 Free Software Foundation, Inc.
2692 +!
2693 +! This program is free software; you can redistribute it and/or modify
2694 +! it under the terms of the GNU General Public License as published by
2695 +! the Free Software Foundation; either version 3 of the License, or
2696 +! (at your option) any later version.
2697 +!
2698 +! This program is distributed in the hope that it will be useful,
2699 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
2700 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2701 +! GNU General Public License for more details.
2702 +!
2703 +! You should have received a copy of the GNU General Public License
2704 +! along with this program.  If not, see <http://www.gnu.org/licenses/>.
2705 +
2706 +program vla
2707 +  real, target, allocatable :: vla1 (:, :, :)
2708 +  real, target, allocatable :: vla2 (:, :, :)
2709 +  real, target, allocatable :: vla3 (:, :)
2710 +  real, pointer :: pvla (:, :, :)
2711 +  logical :: l
2712 +
2713 +  allocate (vla1 (10,10,10))          ! vla1-init
2714 +  l = allocated(vla1)
2715 +
2716 +  allocate (vla2 (1:7,42:50,13:35))   ! vla1-allocated
2717 +  l = allocated(vla2)
2718 +
2719 +  vla1(:, :, :) = 1311                ! vla2-allocated
2720 +  vla1(3, 6, 9) = 42
2721 +  vla1(1, 3, 8) = 1001
2722 +  vla1(6, 2, 7) = 13
2723 +
2724 +  vla2(:, :, :) = 1311                ! vla1-filled
2725 +  vla2(5, 45, 20) = 42
2726 +
2727 +  pvla => vla1                        ! vla2-filled
2728 +  l = associated(pvla)
2729 +
2730 +  pvla => vla2                        ! pvla-associated
2731 +  l = associated(pvla)
2732 +  pvla(5, 45, 20) = 1
2733 +  pvla(7, 45, 14) = 2
2734 +
2735 +  pvla => null()                      ! pvla-re-associated
2736 +  l = associated(pvla)
2737 +
2738 +  deallocate (vla1)                   ! pvla-deassociated
2739 +  l = allocated(vla1)
2740 +
2741 +  deallocate (vla2)                   ! vla1-deallocated
2742 +  l = allocated(vla2)
2743 +
2744 +  allocate (vla3 (2,2))               ! vla2-deallocated
2745 +  vla3(:,:) = 13
2746 +end program vla
2747 diff --git a/gdb/testsuite/gdb.mi/mi-vla-fortran.exp b/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
2748 new file mode 100644
2749 index 0000000..72b0be2
2750 --- /dev/null
2751 +++ b/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
2752 @@ -0,0 +1,182 @@
2753 +# Copyright 2014 Free Software Foundation, Inc.
2754 +
2755 +# This program is free software; you can redistribute it and/or modify
2756 +# it under the terms of the GNU General Public License as published by
2757 +# the Free Software Foundation; either version 3 of the License, or
2758 +# (at your option) any later version.
2759 +#
2760 +# This program is distributed in the hope that it will be useful,
2761 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
2762 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2763 +# GNU General Public License for more details.
2764 +#
2765 +# You should have received a copy of the GNU General Public License
2766 +# along with this program.  If not, see <http://www.gnu.org/licenses/>.
2767 +
2768 +# Verify that, using the MI, we can evaluate a simple C Variable Length
2769 +# Array (VLA).
2770 +
2771 +load_lib mi-support.exp
2772 +set MIFLAGS "-i=mi"
2773 +
2774 +gdb_exit
2775 +if [mi_gdb_start] {
2776 +    continue
2777 +}
2778 +
2779 +standard_testfile vla.f90
2780 +
2781 +if { [gdb_compile "${srcdir}/${subdir}/${srcfile}" "${binfile}" executable \
2782 +     {debug f90}] != "" } {
2783 +     untested mi-vla-fortran.exp
2784 +     return -1
2785 +}
2786 +
2787 +mi_delete_breakpoints
2788 +mi_gdb_reinitialize_dir $srcdir/$subdir
2789 +mi_gdb_load ${binfile}
2790 +
2791 +set bp_lineno [gdb_get_line_number "vla1-not-allocated"]
2792 +mi_create_breakpoint "-t vla.f90:$bp_lineno" 1 "del" "vla" \
2793 +  ".*vla.f90" $bp_lineno $hex \
2794 +  "insert breakpoint at line $bp_lineno (vla not allocated)"
2795 +mi_run_cmd
2796 +mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
2797 +  { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
2798 +mi_gdb_test "500-data-evaluate-expression vla1" \
2799 +  "500\\^done,value=\"<not allocated>\"" "evaluate not allocated vla"
2800 +
2801 +mi_create_varobj_checked vla1_not_allocated vla1 "<not allocated>" \
2802 +  "create local variable vla1_not_allocated"
2803 +mi_gdb_test "501-var-info-type vla1_not_allocated" \
2804 +  "501\\^done,type=\"<not allocated>\"" \
2805 +  "info type variable vla1_not_allocated"
2806 +mi_gdb_test "502-var-show-format vla1_not_allocated" \
2807 +  "502\\^done,format=\"natural\"" \
2808 +  "show format variable vla1_not_allocated"
2809 +mi_gdb_test "503-var-evaluate-expression vla1_not_allocated" \
2810 +  "503\\^done,value=\"\\\[0\\\]\"" \
2811 +  "eval variable vla1_not_allocated"
2812 +mi_list_array_varobj_children_with_index "vla1_not_allocated" "0" "1" \
2813 +    "real\\\(kind=4\\\)" "get children of vla1_not_allocated"
2814 +
2815 +
2816 +
2817 +set bp_lineno [gdb_get_line_number "vla1-allocated"]
2818 +mi_create_breakpoint "-t vla.f90:$bp_lineno" 2 "del" "vla" ".*vla.f90" \
2819 +  $bp_lineno $hex "insert breakpoint at line $bp_lineno (vla allocated)"
2820 +mi_run_cmd
2821 +mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
2822 +  { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
2823 +mi_gdb_test "510-data-evaluate-expression vla1" \
2824 +  "510\\^done,value=\"\\(0, 0, 0, 0, 0\\)\"" "evaluate allocated vla"
2825 +
2826 +mi_create_varobj_checked vla1_allocated vla1 "real\\\(kind=4\\\) \\\(5\\\)" \
2827 +  "create local variable vla1_allocated"
2828 +mi_gdb_test "511-var-info-type vla1_allocated" \
2829 +  "511\\^done,type=\"real\\\(kind=4\\\) \\\(5\\\)\"" \
2830 +  "info type variable vla1_allocated"
2831 +mi_gdb_test "512-var-show-format vla1_allocated" \
2832 +  "512\\^done,format=\"natural\"" \
2833 +  "show format variable vla1_allocated"
2834 +mi_gdb_test "513-var-evaluate-expression vla1_allocated" \
2835 +  "513\\^done,value=\"\\\[5\\\]\"" \
2836 +  "eval variable vla1_allocated"
2837 +mi_list_array_varobj_children_with_index "vla1_allocated" "5" "1" \
2838 +    "real\\\(kind=4\\\)" "get children of vla1_allocated"
2839 +
2840 +
2841 +set bp_lineno [gdb_get_line_number "vla1-filled"]
2842 +mi_create_breakpoint "-t vla.f90:$bp_lineno" 3 "del" "vla" ".*vla.f90" \
2843 +  $bp_lineno $hex "insert breakpoint at line $bp_lineno"
2844 +mi_run_cmd
2845 +mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
2846 +  { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
2847 +mi_gdb_test "520-data-evaluate-expression vla1" \
2848 +  "520\\^done,value=\"\\(1, 1, 1, 1, 1\\)\"" "evaluate filled vla"
2849 +
2850 +
2851 +set bp_lineno [gdb_get_line_number "vla1-modified"]
2852 +mi_create_breakpoint "-t vla.f90:$bp_lineno" 4 "del" "vla" ".*vla.f90" \
2853 +  $bp_lineno $hex "insert breakpoint at line $bp_lineno"
2854 +mi_run_cmd
2855 +mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
2856 +  { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
2857 +mi_gdb_test "530-data-evaluate-expression vla1" \
2858 +  "530\\^done,value=\"\\(1, 42, 1, 24, 1\\)\"" "evaluate filled vla"
2859 +mi_gdb_test "540-data-evaluate-expression vla1(1)" \
2860 +  "540\\^done,value=\"1\"" "evaluate filled vla"
2861 +mi_gdb_test "550-data-evaluate-expression vla1(2)" \
2862 +  "550\\^done,value=\"42\"" "evaluate filled vla"
2863 +mi_gdb_test "560-data-evaluate-expression vla1(4)" \
2864 +  "560\\^done,value=\"24\"" "evaluate filled vla"
2865 +
2866 +
2867 +set bp_lineno [gdb_get_line_number "vla1-deallocated"]
2868 +mi_create_breakpoint "-t vla.f90:$bp_lineno" 5 "del" "vla" ".*vla.f90" \
2869 +  $bp_lineno $hex "insert breakpoint at line $bp_lineno"
2870 +mi_run_cmd
2871 +mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
2872 +  { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
2873 +mi_gdb_test "570-data-evaluate-expression vla1" \
2874 +  "570\\^done,value=\"<not allocated>\"" "evaluate not allocated vla"
2875 +
2876 +
2877 +set bp_lineno [gdb_get_line_number "pvla2-not-associated"]
2878 +mi_create_breakpoint "-t vla.f90:$bp_lineno" 6 "del" "vla" ".*vla.f90" \
2879 +  $bp_lineno $hex "insert breakpoint at line $bp_lineno"
2880 +mi_run_cmd
2881 +mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
2882 +  { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
2883 +mi_gdb_test "580-data-evaluate-expression pvla2" \
2884 +  "580\\^done,value=\"<not associated>\"" "evaluate not associated vla"
2885 +
2886 +mi_create_varobj_checked pvla2_not_associated pvla2 "<not associated>" \
2887 +  "create local variable pvla2_not_associated"
2888 +mi_gdb_test "581-var-info-type pvla2_not_associated" \
2889 +  "581\\^done,type=\"<not associated>\"" \
2890 +  "info type variable pvla2_not_associated"
2891 +mi_gdb_test "582-var-show-format pvla2_not_associated" \
2892 +  "582\\^done,format=\"natural\"" \
2893 +  "show format variable pvla2_not_associated"
2894 +mi_gdb_test "583-var-evaluate-expression pvla2_not_associated" \
2895 +  "583\\^done,value=\"\\\[0\\\]\"" \
2896 +  "eval variable pvla2_not_associated"
2897 +mi_list_array_varobj_children_with_index "pvla2_not_associated" "0" "1" \
2898 +    "real\\\(kind=4\\\)" "get children of pvla2_not_associated"
2899 +
2900 +
2901 +set bp_lineno [gdb_get_line_number "pvla2-associated"]
2902 +mi_create_breakpoint "-t vla.f90:$bp_lineno" 7 "del" "vla" ".*vla.f90" \
2903 +  $bp_lineno $hex "insert breakpoint at line $bp_lineno"
2904 +mi_run_cmd
2905 +mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
2906 +  { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
2907 +mi_gdb_test "590-data-evaluate-expression pvla2" \
2908 +  "590\\^done,value=\"\\(\\( 2, 2, 2, 2, 2\\) \\( 2, 2, 2, 2, 2\\) \\)\"" \
2909 +  "evaluate associated vla"
2910 +
2911 +mi_create_varobj_checked pvla2_associated pvla2 \
2912 +  "real\\\(kind=4\\\) \\\(5,2\\\)" "create local variable pvla2_associated"
2913 +mi_gdb_test "591-var-info-type pvla2_associated" \
2914 +  "591\\^done,type=\"real\\\(kind=4\\\) \\\(5,2\\\)\"" \
2915 +  "info type variable pvla2_associated"
2916 +mi_gdb_test "592-var-show-format pvla2_associated" \
2917 +  "592\\^done,format=\"natural\"" \
2918 +  "show format variable pvla2_associated"
2919 +mi_gdb_test "593-var-evaluate-expression pvla2_associated" \
2920 +  "593\\^done,value=\"\\\[2\\\]\"" \
2921 +  "eval variable pvla2_associated"
2922 +
2923 +
2924 +set bp_lineno [gdb_get_line_number "pvla2-set-to-null"]
2925 +mi_create_breakpoint "-t vla.f90:$bp_lineno" 8 "del" "vla" ".*vla.f90" \
2926 +  $bp_lineno $hex "insert breakpoint at line $bp_lineno"
2927 +mi_run_cmd
2928 +mi_expect_stop "breakpoint-hit" "vla" "" ".*vla.f90" "$bp_lineno" \
2929 +  { "" "disp=\"del\"" } "run to breakpoint at line $bp_lineno"
2930 +mi_gdb_test "600-data-evaluate-expression pvla2" \
2931 +  "600\\^done,value=\"<not associated>\"" "evaluate vla pointer set to null"
2932 +
2933 +mi_gdb_exit
2934 +return 0
2935 diff --git a/gdb/testsuite/gdb.mi/vla.f90 b/gdb/testsuite/gdb.mi/vla.f90
2936 new file mode 100644
2937 index 0000000..46edad2
2938 --- /dev/null
2939 +++ b/gdb/testsuite/gdb.mi/vla.f90
2940 @@ -0,0 +1,42 @@
2941 +! Copyright 2014 Free Software Foundation, Inc.
2942 +!
2943 +! This program is free software; you can redistribute it and/or modify
2944 +! it under the terms of the GNU General Public License as published by
2945 +! the Free Software Foundation; either version 3 of the License, or
2946 +! (at your option) any later version.
2947 +!
2948 +! This program is distributed in the hope that it will be useful,
2949 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
2950 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
2951 +! GNU General Public License for more details.
2952 +!
2953 +! You should have received a copy of the GNU General Public License
2954 +! along with this program.  If not, see <http://www.gnu.org/licenses/>.
2955 +
2956 +program vla
2957 +  real, allocatable :: vla1 (:)
2958 +  real, target, allocatable :: vla2(:, :)
2959 +  real, pointer :: pvla2 (:, :)
2960 +  logical :: l
2961 +
2962 +  allocate (vla1 (5))         ! vla1-not-allocated
2963 +  l = allocated(vla1)         ! vla1-allocated
2964 +
2965 +  vla1(:) = 1
2966 +  vla1(2) = 42                ! vla1-filled
2967 +  vla1(4) = 24
2968 +
2969 +  deallocate (vla1)           ! vla1-modified
2970 +  l = allocated(vla1)         ! vla1-deallocated
2971 +
2972 +  allocate (vla2 (5, 2))
2973 +  vla2(:, :) = 2
2974 +
2975 +  pvla2 => vla2               ! pvla2-not-associated
2976 +  l = associated(pvla2)       ! pvla2-associated
2977 +
2978 +  pvla2(2, 1) = 42
2979 +
2980 +  pvla2 => null()
2981 +  l = associated(pvla2)       ! pvla2-set-to-null
2982 +end program vla
2983 diff --git a/gdb/typeprint.c b/gdb/typeprint.c
2984 index 026f3a2..4c861ac 100644
2985 --- a/gdb/typeprint.c
2986 +++ b/gdb/typeprint.c
2987 @@ -459,6 +459,13 @@ whatis_exp (char *exp, int show)
2988
2989    type = value_type (val);
2990
2991 +  if (TYPE_CODE (type) == TYPE_CODE_PTR)
2992 +    if (is_dynamic_type (TYPE_TARGET_TYPE (type)))
2993 +      {
2994 +       val = value_addr (value_ind (val));
2995 +       type = value_type (val);
2996 +      }
2997 +
2998    get_user_print_options (&opts);
2999    if (opts.objectprint)
3000      {
3001 diff --git a/gdb/valarith.c b/gdb/valarith.c
3002 index 4da41cb..fb9671b 100644
3003 --- a/gdb/valarith.c
3004 +++ b/gdb/valarith.c
3005 @@ -195,12 +195,31 @@ value_subscripted_rvalue (struct value *array, LONGEST index, int lowerbound)
3006    struct type *array_type = check_typedef (value_type (array));
3007    struct type *elt_type = check_typedef (TYPE_TARGET_TYPE (array_type));
3008    unsigned int elt_size = TYPE_LENGTH (elt_type);
3009 -  unsigned int elt_offs = elt_size * longest_to_int (index - lowerbound);
3010 +  unsigned int elt_offs = longest_to_int (index - lowerbound);
3011 +  LONGEST elt_stride = TYPE_BYTE_STRIDE (TYPE_INDEX_TYPE (array_type));
3012    struct value *v;
3013
3014 +  if (elt_stride > 0)
3015 +    elt_offs *= elt_stride;
3016 +  else if (elt_stride < 0)
3017 +    {
3018 +      int offs = (elt_offs + 1) * elt_stride;
3019 +
3020 +      elt_offs = TYPE_LENGTH (array_type) + offs;
3021 +    }
3022 +  else
3023 +    elt_offs *= elt_size;
3024 +
3025    if (index < lowerbound || (!TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (array_type)
3026                              && elt_offs >= TYPE_LENGTH (array_type)))
3027 -    error (_("no such vector element"));
3028 +    {
3029 +      if (TYPE_NOT_ASSOCIATED (array_type))
3030 +        error (_("no such vector element because not associated"));
3031 +      else if (TYPE_NOT_ALLOCATED (array_type))
3032 +        error (_("no such vector element because not allocated"));
3033 +      else
3034 +        error (_("no such vector element"));
3035 +    }
3036
3037    if (VALUE_LVAL (array) == lval_memory && value_lazy (array))
3038      v = allocate_value_lazy (elt_type);
3039 diff --git a/gdb/valprint.c b/gdb/valprint.c
3040 index 8600b34..2f8eac1 100644
3041 --- a/gdb/valprint.c
3042 +++ b/gdb/valprint.c
3043 @@ -307,6 +307,18 @@ valprint_check_validity (struct ui_file *stream,
3044  {
3045    CHECK_TYPEDEF (type);
3046
3047 +  if (TYPE_NOT_ASSOCIATED (type))
3048 +    {
3049 +      val_print_not_associated (stream);
3050 +      return 0;
3051 +    }
3052 +
3053 +  if (TYPE_NOT_ALLOCATED (type))
3054 +    {
3055 +      val_print_not_allocated (stream);
3056 +      return 0;
3057 +    }
3058 +
3059    if (TYPE_CODE (type) != TYPE_CODE_UNION
3060        && TYPE_CODE (type) != TYPE_CODE_STRUCT
3061        && TYPE_CODE (type) != TYPE_CODE_ARRAY)
3062 @@ -362,6 +374,18 @@ val_print_invalid_address (struct ui_file *stream)
3063    fprintf_filtered (stream, _("<invalid address>"));
3064  }
3065
3066 +void
3067 +val_print_not_allocated (struct ui_file *stream)
3068 +{
3069 +  fprintf_filtered (stream, _("<not allocated>"));
3070 +}
3071 +
3072 +void
3073 +val_print_not_associated (struct ui_file *stream)
3074 +{
3075 +  fprintf_filtered (stream, _("<not associated>"));
3076 +}
3077 +
3078  /* A generic val_print that is suitable for use by language
3079     implementations of the la_val_print method.  This function can
3080     handle most type codes, though not all, notably exception
3081 @@ -803,12 +827,16 @@ static int
3082  value_check_printable (struct value *val, struct ui_file *stream,
3083                        const struct value_print_options *options)
3084  {
3085 +  const struct type *type;
3086 +
3087    if (val == 0)
3088      {
3089        fprintf_filtered (stream, _("<address of value unknown>"));
3090        return 0;
3091      }
3092
3093 +  type = value_type (val);
3094 +
3095    if (value_entirely_optimized_out (val))
3096      {
3097        if (options->summary && !val_print_scalar_type_p (value_type (val)))
3098 @@ -834,6 +862,18 @@ value_check_printable (struct value *val, struct ui_file *stream,
3099        return 0;
3100      }
3101
3102 +  if (TYPE_NOT_ASSOCIATED (type))
3103 +    {
3104 +      val_print_not_associated (stream);
3105 +      return 0;
3106 +    }
3107 +
3108 +  if (TYPE_NOT_ALLOCATED (type))
3109 +    {
3110 +      val_print_not_allocated (stream);
3111 +      return 0;
3112 +    }
3113 +
3114    return 1;
3115  }
3116
3117 diff --git a/gdb/valprint.h b/gdb/valprint.h
3118 index 6698247..7a415cf 100644
3119 --- a/gdb/valprint.h
3120 +++ b/gdb/valprint.h
3121 @@ -217,4 +217,8 @@ extern void output_command_const (const char *args, int from_tty);
3122
3123  extern int val_print_scalar_type_p (struct type *type);
3124
3125 +extern void val_print_not_allocated (struct ui_file *stream);
3126 +
3127 +extern void val_print_not_associated (struct ui_file *stream);
3128 +
3129  #endif
3130 diff --git a/gdb/value.c b/gdb/value.c
3131 index 29abe5f..5efea89 100644
3132 --- a/gdb/value.c
3133 +++ b/gdb/value.c
3134 @@ -43,6 +43,7 @@
3135  #include "tracepoint.h"
3136  #include "cp-abi.h"
3137  #include "user-regs.h"
3138 +#include "dwarf2loc.h"
3139
3140  /* Prototypes for exported functions.  */
3141
3142 @@ -1627,6 +1628,25 @@ set_value_component_location (struct value *component,
3143        if (funcs->copy_closure)
3144          component->location.computed.closure = funcs->copy_closure (whole);
3145      }
3146 +
3147 +  /* For dynamic types compute the address of the component value location in
3148 +     sub range types based on the location of the sub range type, if not being
3149 +     an internal GDB variable or parts of it.  */
3150 +  if (VALUE_LVAL (component) != lval_internalvar
3151 +      && VALUE_LVAL (component) != lval_internalvar_component)
3152 +    {
3153 +      CORE_ADDR addr;
3154 +      struct type *type = value_type (whole);
3155 +
3156 +      addr = value_raw_address (component);
3157 +
3158 +      if (TYPE_DATA_LOCATION (type)
3159 +          && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
3160 +        {
3161 +          addr = TYPE_DATA_LOCATION_ADDR (type);
3162 +          set_value_address (component, addr);
3163 +        }
3164 +    }
3165  }
3166
3167  \f
3168 @@ -2931,13 +2951,22 @@ value_primitive_field (struct value *arg1, int offset,
3169         v = allocate_value_lazy (type);
3170        else
3171         {
3172 -         v = allocate_value (type);
3173 -         value_contents_copy_raw (v, value_embedded_offset (v),
3174 -                                  arg1, value_embedded_offset (arg1) + offset,
3175 -                                  TYPE_LENGTH (type));
3176 +         if (TYPE_DATA_LOCATION (type)
3177 +             && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
3178 +           v = value_at_lazy (type, value_address (arg1) + offset);
3179 +         else
3180 +           {
3181 +             v = allocate_value (type);
3182 +             value_contents_copy_raw (v, value_embedded_offset (v),
3183 +                                      arg1, value_embedded_offset (arg1) + offset,
3184 +                                      TYPE_LENGTH (type));
3185 +           }
3186         }
3187 -      v->offset = (value_offset (arg1) + offset
3188 -                  + value_embedded_offset (arg1));
3189 +
3190 +      if (!TYPE_DATA_LOCATION (type)
3191 +          || !TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
3192 +       v->offset = (value_offset (arg1) + offset
3193 +                    + value_embedded_offset (arg1));
3194      }
3195    set_value_component_location (v, arg1);
3196    VALUE_REGNUM (v) = VALUE_REGNUM (arg1);
3197 @@ -3520,7 +3549,8 @@ readjust_indirect_value_type (struct value *value, struct type *enc_type,
3198                               struct value *original_value)
3199  {
3200    /* Re-adjust type.  */
3201 -  deprecated_set_value_type (value, TYPE_TARGET_TYPE (original_type));
3202 +  if (!is_dynamic_type (TYPE_TARGET_TYPE (original_type)))
3203 +    deprecated_set_value_type (value, TYPE_TARGET_TYPE (original_type));
3204
3205    /* Add embedding info.  */
3206    set_value_enclosing_type (value, enc_type);
3207 @@ -3537,6 +3567,12 @@ coerce_ref (struct value *arg)
3208    struct value *retval;
3209    struct type *enc_type;
3210
3211 +  if (current_language->la_language != language_fortran
3212 +      && TYPE_DATA_LOCATION (value_type_arg_tmp) != NULL
3213 +      && TYPE_DATA_LOCATION_KIND (value_type_arg_tmp) == PROP_CONST)
3214 +    arg = value_at_lazy (value_type_arg_tmp,
3215 +                         TYPE_DATA_LOCATION_ADDR (value_type_arg_tmp));
3216 +
3217    retval = coerce_ref_if_computed (arg);
3218    if (retval)
3219      return retval;
3220 @@ -3680,8 +3716,14 @@ value_fetch_lazy (struct value *val)
3221      }
3222    else if (VALUE_LVAL (val) == lval_memory)
3223      {
3224 -      CORE_ADDR addr = value_address (val);
3225        struct type *type = check_typedef (value_enclosing_type (val));
3226 +      CORE_ADDR addr;
3227 +
3228 +      if (TYPE_DATA_LOCATION (type) != NULL
3229 +         && TYPE_DATA_LOCATION_KIND (type) == PROP_CONST)
3230 +       addr = TYPE_DATA_LOCATION_ADDR (type);
3231 +      else
3232 +       addr = value_address (val);
3233
3234        if (TYPE_LENGTH (type))
3235         read_value_memory (val, 0, value_stack (val),