1 git diff --stat -p gdb/master...gdb/users/bheckel/fortran-vla-strings
2 0ad7d8d1a3a36c6e04e3b6d37d8825f18d595723
5 gdb/c-valprint.c | 22 +++++
6 gdb/dwarf2read.c | 158 +++++++++++++++++++++++++-----
7 gdb/f-typeprint.c | 93 +++++++++---------
8 gdb/gdbtypes.c | 44 ++++++++-
9 gdb/testsuite/gdb.cp/vla-cxx.cc | 9 ++
10 gdb/testsuite/gdb.cp/vla-cxx.exp | 9 ++
11 gdb/testsuite/gdb.fortran/pointers.exp | 143 +++++++++++++++++++++++++++
12 gdb/testsuite/gdb.fortran/pointers.f90 | 109 +++++++++++++++++++++
13 gdb/testsuite/gdb.fortran/print_type.exp | 100 +++++++++++++++++++
14 gdb/testsuite/gdb.fortran/vla-ptype.exp | 12 +--
15 gdb/testsuite/gdb.fortran/vla-strings.exp | 103 +++++++++++++++++++
16 gdb/testsuite/gdb.fortran/vla-strings.f90 | 39 ++++++++
17 gdb/testsuite/gdb.fortran/vla-type.exp | 7 +-
18 gdb/testsuite/gdb.fortran/vla-value.exp | 12 ++-
19 gdb/testsuite/gdb.mi/mi-var-child-f.exp | 7 +-
20 gdb/testsuite/gdb.mi/mi-vla-fortran.exp | 27 ++---
21 gdb/typeprint.c | 19 ++++
24 20 files changed, 827 insertions(+), 110 deletions(-)
26 Index: gdb-7.99.90.20170420/gdb/NEWS
27 ===================================================================
28 --- gdb-7.99.90.20170420.orig/gdb/NEWS 2017-04-20 22:27:47.076032111 +0200
29 +++ gdb-7.99.90.20170420/gdb/NEWS 2017-04-20 22:27:49.946050236 +0200
31 What has changed in GDB?
32 (Organized release by release)
34 +* Fortran: Support pointers to dynamic types.
36 *** Changes in GDB 8.0
38 * GDB now supports access to the PKU register on GNU/Linux. The register is
39 Index: gdb-7.99.90.20170420/gdb/c-valprint.c
40 ===================================================================
41 --- gdb-7.99.90.20170420.orig/gdb/c-valprint.c 2017-04-20 22:27:47.077032118 +0200
42 +++ gdb-7.99.90.20170420/gdb/c-valprint.c 2017-04-20 22:27:49.947050243 +0200
47 + if (TYPE_CODE (type) == TYPE_CODE_PTR
48 + && 1 == is_dynamic_type (type))
51 + if (NULL != TYPE_DATA_LOCATION (TYPE_TARGET_TYPE (type)))
52 + addr = value_address (val);
54 + addr = value_as_address (val);
56 + /* We resolve the target-type only when the
57 + pointer is associated. */
59 + && (0 == type_not_associated (type)))
60 + TYPE_TARGET_TYPE (type) =
61 + resolve_dynamic_type (TYPE_TARGET_TYPE (type),
66 + /* Do nothing. References are already resolved from the beginning,
67 + only pointers are resolved when we actual need the target. */
69 fprintf_filtered (stream, "(");
70 type_print (value_type (val), "", stream, -1);
71 fprintf_filtered (stream, ") ");
72 Index: gdb-7.99.90.20170420/gdb/dwarf2read.c
73 ===================================================================
74 --- gdb-7.99.90.20170420.orig/gdb/dwarf2read.c 2017-04-20 22:27:47.091032206 +0200
75 +++ gdb-7.99.90.20170420/gdb/dwarf2read.c 2017-04-20 22:28:28.878296105 +0200
78 static int attr_to_dynamic_prop (const struct attribute *attr,
79 struct die_info *die, struct dwarf2_cu *cu,
80 - struct dynamic_prop *prop);
81 + struct dynamic_prop *prop, const gdb_byte *additional_data,
82 + int additional_data_size);
84 /* memory allocation interface */
86 @@ -11557,7 +11558,7 @@
89 = XOBNEW (&objfile->objfile_obstack, struct dynamic_prop);
90 - attr_to_dynamic_prop (attr, die, cu, newobj->static_link);
91 + attr_to_dynamic_prop (attr, die, cu, newobj->static_link, NULL, 0);
94 cu->list_in_scope = &local_symbols;
95 @@ -14791,29 +14792,94 @@
96 struct gdbarch *gdbarch = get_objfile_arch (objfile);
97 struct type *type, *range_type, *index_type, *char_type;
98 struct attribute *attr;
99 - unsigned int length;
100 + unsigned int length = UINT_MAX;
102 + index_type = objfile_type (objfile)->builtin_int;
103 + range_type = create_static_range_type (NULL, index_type, 1, length);
105 + /* If DW_AT_string_length is defined, the length is stored in memory. */
106 attr = dwarf2_attr (die, DW_AT_string_length, cu);
109 - length = DW_UNSND (attr);
110 + if (attr_form_is_block (attr))
112 + struct attribute *byte_size, *bit_size;
113 + struct dynamic_prop high;
115 + byte_size = dwarf2_attr (die, DW_AT_byte_size, cu);
116 + bit_size = dwarf2_attr (die, DW_AT_bit_size, cu);
118 + /* DW_AT_byte_size should never occur in combination with
120 + if (byte_size != NULL && bit_size != NULL)
121 + complaint (&symfile_complaints,
122 + _("DW_AT_byte_size AND "
123 + "DW_AT_bit_size found together at the same time."));
125 + /* If DW_AT_string_length AND DW_AT_byte_size exist together,
126 + DW_AT_byte_size describes the number of bytes that should be read
127 + from the length memory location. */
128 + if (byte_size != NULL)
130 + /* Build new dwarf2_locexpr_baton structure with additions to the
131 + data attribute, to reflect DWARF specialities to get address
133 + const gdb_byte append_ops[] =
135 + /* DW_OP_deref_size: size of an address on the target machine
136 + (bytes), where the size will be specified by the next
139 + /* Operand for DW_OP_deref_size. */
140 + DW_UNSND(byte_size) };
142 + if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
143 + ARRAY_SIZE(append_ops)))
144 + complaint (&symfile_complaints,
145 + _("Could not parse DW_AT_byte_size"));
147 + else if (bit_size != NULL)
148 + complaint (&symfile_complaints,
149 + _("DW_AT_string_length AND "
150 + "DW_AT_bit_size found but not supported yet."));
151 + /* If DW_AT_string_length WITHOUT DW_AT_byte_size exist, the default
152 + is the address size of the target machine. */
155 + const gdb_byte append_ops[] =
158 + if (!attr_to_dynamic_prop (attr, die, cu, &high, append_ops,
159 + ARRAY_SIZE(append_ops)))
160 + complaint (&symfile_complaints,
161 + _("Could not parse DW_AT_string_length"));
164 + TYPE_RANGE_DATA (range_type)->high = high;
168 + TYPE_HIGH_BOUND (range_type) = DW_UNSND(attr);
169 + TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
174 - /* Check for the DW_AT_byte_size attribute. */
175 + /* Check for the DW_AT_byte_size attribute, which represents the length
177 attr = dwarf2_attr (die, DW_AT_byte_size, cu);
180 - length = DW_UNSND (attr);
183 + TYPE_HIGH_BOUND (range_type) = DW_UNSND(attr);
184 + TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
191 + TYPE_HIGH_BOUND (range_type) = 1;
192 + TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST;
196 - index_type = objfile_type (objfile)->builtin_int;
197 - range_type = create_static_range_type (NULL, index_type, 1, length);
198 char_type = language_string_char_type (cu->language_defn, gdbarch);
199 type = create_string_type (NULL, char_type, range_type);
201 @@ -15163,7 +15229,8 @@
204 attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die,
205 - struct dwarf2_cu *cu, struct dynamic_prop *prop)
206 + struct dwarf2_cu *cu, struct dynamic_prop *prop,
207 + const gdb_byte *additional_data, int additional_data_size)
209 struct dwarf2_property_baton *baton;
210 struct obstack *obstack = &cu->objfile->objfile_obstack;
211 @@ -15173,14 +15240,33 @@
213 if (attr_form_is_block (attr))
215 - baton = XOBNEW (obstack, struct dwarf2_property_baton);
216 + baton = XOBNEW(obstack, struct dwarf2_property_baton);
217 baton->referenced_type = NULL;
218 baton->locexpr.per_cu = cu->per_cu;
219 - baton->locexpr.size = DW_BLOCK (attr)->size;
220 - baton->locexpr.data = DW_BLOCK (attr)->data;
222 + if (additional_data != NULL && additional_data_size > 0)
226 + data = (gdb_byte *) obstack_alloc(
227 + &cu->objfile->objfile_obstack,
228 + DW_BLOCK (attr)->size + additional_data_size);
229 + memcpy (data, DW_BLOCK (attr)->data, DW_BLOCK (attr)->size);
230 + memcpy (data + DW_BLOCK (attr)->size, additional_data,
231 + additional_data_size);
233 + baton->locexpr.data = data;
234 + baton->locexpr.size = DW_BLOCK (attr)->size + additional_data_size;
238 + baton->locexpr.data = DW_BLOCK (attr)->data;
239 + baton->locexpr.size = DW_BLOCK (attr)->size;
242 prop->data.baton = baton;
243 prop->kind = PROP_LOCEXPR;
244 - gdb_assert (prop->data.baton != NULL);
245 + gdb_assert(prop->data.baton != NULL);
247 else if (attr_form_is_ref (attr))
249 @@ -15213,8 +15299,28 @@
250 baton = XOBNEW (obstack, struct dwarf2_property_baton);
251 baton->referenced_type = die_type (target_die, target_cu);
252 baton->locexpr.per_cu = cu->per_cu;
253 - baton->locexpr.size = DW_BLOCK (target_attr)->size;
254 - baton->locexpr.data = DW_BLOCK (target_attr)->data;
256 + if (additional_data != NULL && additional_data_size > 0)
260 + data = (gdb_byte *) obstack_alloc (&cu->objfile->objfile_obstack,
261 + DW_BLOCK (target_attr)->size + additional_data_size);
262 + memcpy (data, DW_BLOCK (target_attr)->data,
263 + DW_BLOCK (target_attr)->size);
264 + memcpy (data + DW_BLOCK (target_attr)->size,
265 + additional_data, additional_data_size);
267 + baton->locexpr.data = data;
268 + baton->locexpr.size = (DW_BLOCK (target_attr)->size
269 + + additional_data_size);
273 + baton->locexpr.data = DW_BLOCK (target_attr)->data;
274 + baton->locexpr.size = DW_BLOCK (target_attr)->size;
277 prop->data.baton = baton;
278 prop->kind = PROP_LOCEXPR;
279 gdb_assert (prop->data.baton != NULL);
280 @@ -15325,24 +15431,24 @@
282 attr = dwarf2_attr (die, DW_AT_byte_stride, cu);
284 - if (!attr_to_dynamic_prop (attr, die, cu, &stride))
285 + if (!attr_to_dynamic_prop (attr, die, cu, &stride, NULL, 0))
286 complaint (&symfile_complaints, _("Missing DW_AT_byte_stride "
287 "- DIE at 0x%x [in module %s]"),
288 to_underlying (die->sect_off), objfile_name (cu->objfile));
290 attr = dwarf2_attr (die, DW_AT_lower_bound, cu);
292 - attr_to_dynamic_prop (attr, die, cu, &low);
293 + attr_to_dynamic_prop (attr, die, cu, &low, NULL, 0);
294 else if (!low_default_is_valid)
295 complaint (&symfile_complaints, _("Missing DW_AT_lower_bound "
296 "- DIE at 0x%x [in module %s]"),
297 to_underlying (die->sect_off), objfile_name (cu->objfile));
299 attr = dwarf2_attr (die, DW_AT_upper_bound, cu);
300 - if (!attr_to_dynamic_prop (attr, die, cu, &high))
301 + if (!attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))
303 attr = dwarf2_attr (die, DW_AT_count, cu);
304 - if (attr_to_dynamic_prop (attr, die, cu, &high))
305 + if (attr_to_dynamic_prop (attr, die, cu, &high, NULL, 0))
307 /* If bounds are constant do the final calculation here. */
308 if (low.kind == PROP_CONST && high.kind == PROP_CONST)
309 @@ -22967,7 +23073,7 @@
310 attr = dwarf2_attr (die, DW_AT_allocated, cu);
311 if (attr_form_is_block (attr))
313 - if (attr_to_dynamic_prop (attr, die, cu, &prop))
314 + if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
315 add_dyn_prop (DYN_PROP_ALLOCATED, prop, type, objfile);
317 else if (attr != NULL)
318 @@ -22982,7 +23088,7 @@
319 attr = dwarf2_attr (die, DW_AT_associated, cu);
320 if (attr_form_is_block (attr))
322 - if (attr_to_dynamic_prop (attr, die, cu, &prop))
323 + if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
324 add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type, objfile);
326 else if (attr != NULL)
327 @@ -22995,7 +23101,7 @@
329 /* Read DW_AT_data_location and set in type. */
330 attr = dwarf2_attr (die, DW_AT_data_location, cu);
331 - if (attr_to_dynamic_prop (attr, die, cu, &prop))
332 + if (attr_to_dynamic_prop (attr, die, cu, &prop, NULL, 0))
333 add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type, objfile);
335 if (dwarf2_per_objfile->die_type_hash == NULL)
336 Index: gdb-7.99.90.20170420/gdb/f-typeprint.c
337 ===================================================================
338 --- gdb-7.99.90.20170420.orig/gdb/f-typeprint.c 2017-04-20 22:27:26.288900835 +0200
339 +++ gdb-7.99.90.20170420/gdb/f-typeprint.c 2017-04-20 22:27:49.953050280 +0200
343 static void f_type_print_varspec_suffix (struct type *, struct ui_file *, int,
345 + int, int, int, int);
347 void f_type_print_varspec_prefix (struct type *, struct ui_file *,
353 - if (type_not_associated (type))
355 - val_print_not_associated (stream);
359 - if (type_not_allocated (type))
361 - val_print_not_allocated (stream);
365 f_type_print_base (type, stream, show, level);
366 code = TYPE_CODE (type);
367 if ((varstring != NULL && *varstring != '\0')
370 demangled_args = (*varstring != '\0'
371 && varstring[strlen (varstring) - 1] == ')');
372 - f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0);
373 + f_type_print_varspec_suffix (type, stream, show, 0, demangled_args, 0, 0);
379 f_type_print_varspec_suffix (struct type *type, struct ui_file *stream,
380 int show, int passed_a_ptr, int demangled_args,
381 - int arrayprint_recurse_level)
382 + int arrayprint_recurse_level, int print_rank_only)
384 int upper_bound, lower_bound;
386 @@ -183,34 +171,50 @@
387 fprintf_filtered (stream, "(");
389 if (type_not_associated (type))
390 - val_print_not_associated (stream);
391 + print_rank_only = 1;
392 else if (type_not_allocated (type))
393 - val_print_not_allocated (stream);
394 + print_rank_only = 1;
395 + else if ((TYPE_ASSOCIATED_PROP (type)
396 + && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ASSOCIATED_PROP (type)))
397 + || (TYPE_ALLOCATED_PROP (type)
398 + && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ALLOCATED_PROP (type)))
399 + || (TYPE_DATA_LOCATION (type)
400 + && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_DATA_LOCATION (type))))
401 + /* This case exist when we ptype a typename which has the
402 + dynamic properties but cannot be resolved as there is
404 + print_rank_only = 1;
406 + if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
407 + f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
408 + 0, 0, arrayprint_recurse_level,
411 + if (print_rank_only == 1)
412 + fprintf_filtered (stream, ":");
415 - if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY)
416 - f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
417 - 0, 0, arrayprint_recurse_level);
419 - lower_bound = f77_get_lowerbound (type);
420 - if (lower_bound != 1) /* Not the default. */
421 - fprintf_filtered (stream, "%d:", lower_bound);
423 - /* Make sure that, if we have an assumed size array, we
424 - print out a warning and print the upperbound as '*'. */
426 - if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
427 - fprintf_filtered (stream, "*");
430 - upper_bound = f77_get_upperbound (type);
431 - fprintf_filtered (stream, "%d", upper_bound);
434 - if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
435 - f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
436 - 0, 0, arrayprint_recurse_level);
439 + lower_bound = f77_get_lowerbound (type);
440 + if (lower_bound != 1) /* Not the default. */
441 + fprintf_filtered (stream, "%d:", lower_bound);
443 + /* Make sure that, if we have an assumed size array, we
444 + print out a warning and print the upperbound as '*'. */
446 + if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
447 + fprintf_filtered (stream, "*");
450 + upper_bound = f77_get_upperbound (type);
451 + fprintf_filtered (stream, "%d", upper_bound);
455 + if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_ARRAY)
456 + f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
457 + 0, 0, arrayprint_recurse_level,
460 if (arrayprint_recurse_level == 1)
461 fprintf_filtered (stream, ")");
463 @@ -221,13 +225,14 @@
466 f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0,
467 - arrayprint_recurse_level);
468 + arrayprint_recurse_level, 0);
469 fprintf_filtered (stream, ")");
473 f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
474 - passed_a_ptr, 0, arrayprint_recurse_level);
475 + passed_a_ptr, 0, arrayprint_recurse_level,
478 fprintf_filtered (stream, ")");
481 fputs_filtered (" :: ", stream);
482 fputs_filtered (TYPE_FIELD_NAME (type, index), stream);
483 f_type_print_varspec_suffix (TYPE_FIELD_TYPE (type, index),
484 - stream, show - 1, 0, 0, 0);
485 + stream, show - 1, 0, 0, 0, 0);
486 fputs_filtered ("\n", stream);
488 fprintfi_filtered (level, stream, "End Type ");
489 Index: gdb-7.99.90.20170420/gdb/gdbtypes.c
490 ===================================================================
491 --- gdb-7.99.90.20170420.orig/gdb/gdbtypes.c 2017-04-20 22:27:47.093032219 +0200
492 +++ gdb-7.99.90.20170420/gdb/gdbtypes.c 2017-04-20 22:27:49.954050287 +0200
493 @@ -1840,7 +1840,8 @@
494 type = check_typedef (type);
496 /* We only want to recognize references at the outermost level. */
497 - if (top_level && TYPE_CODE (type) == TYPE_CODE_REF)
499 + (TYPE_CODE (type) == TYPE_CODE_REF || TYPE_CODE (type) == TYPE_CODE_PTR))
500 type = check_typedef (TYPE_TARGET_TYPE (type));
502 /* Types that have a dynamic TYPE_DATA_LOCATION are considered
503 @@ -1874,6 +1875,7 @@
506 case TYPE_CODE_ARRAY:
507 + case TYPE_CODE_STRING:
509 gdb_assert (TYPE_NFIELDS (type) == 1);
511 @@ -1986,7 +1988,8 @@
512 struct type *ary_dim;
513 struct dynamic_prop *prop;
515 - gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY);
516 + gdb_assert (TYPE_CODE (type) == TYPE_CODE_ARRAY
517 + || TYPE_CODE (type) == TYPE_CODE_STRING);
519 type = copy_type (type);
521 @@ -2011,13 +2014,17 @@
523 ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type));
525 - if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY)
526 + if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY
527 + || TYPE_CODE (ary_dim) == TYPE_CODE_STRING))
528 elt_type = resolve_dynamic_array (ary_dim, addr_stack);
530 elt_type = TYPE_TARGET_TYPE (type);
532 - return create_array_type_with_stride (type, elt_type, range_type,
533 - TYPE_FIELD_BITSIZE (type, 0));
534 + if (TYPE_CODE (type) == TYPE_CODE_STRING)
535 + return create_string_type (type, elt_type, range_type);
537 + return create_array_type_with_stride (type, elt_type, range_type,
538 + TYPE_FIELD_BITSIZE (type, 0));
541 /* Resolve dynamic bounds of members of the union TYPE to static
542 @@ -2147,6 +2154,28 @@
543 return resolved_type;
546 +/* Worker for pointer types. */
548 +static struct type *
549 +resolve_dynamic_pointer (struct type *type,
550 + struct property_addr_info *addr_stack)
552 + struct dynamic_prop *prop;
555 + type = copy_type (type);
557 + /* Resolve associated property. */
558 + prop = TYPE_ASSOCIATED_PROP (type);
559 + if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value))
561 + TYPE_DYN_PROP_ADDR (prop) = value;
562 + TYPE_DYN_PROP_KIND (prop) = PROP_CONST;
568 /* Worker for resolved_dynamic_type. */
571 @@ -2195,7 +2224,12 @@
575 + case TYPE_CODE_PTR:
576 + resolved_type = resolve_dynamic_pointer (type, addr_stack);
579 case TYPE_CODE_ARRAY:
580 + case TYPE_CODE_STRING:
581 resolved_type = resolve_dynamic_array (type, addr_stack);
584 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.cp/vla-cxx.cc
585 ===================================================================
586 --- gdb-7.99.90.20170420.orig/gdb/testsuite/gdb.cp/vla-cxx.cc 2017-04-20 22:27:47.094032225 +0200
587 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.cp/vla-cxx.cc 2017-04-20 22:27:49.955050293 +0200
589 You should have received a copy of the GNU General Public License
590 along with this program. If not, see <http://www.gnu.org/licenses/>. */
600 typedef typeof (vla) &vlareftypedef;
601 vlareftypedef vlaref2 (vla);
603 + typeof (vla) *ptr = NULL;
605 + // Before pointer assignment
608 for (int i = 0; i < z; ++i)
616 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.cp/vla-cxx.exp
617 ===================================================================
618 --- gdb-7.99.90.20170420.orig/gdb/testsuite/gdb.cp/vla-cxx.exp 2017-04-20 22:27:47.094032225 +0200
619 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.cp/vla-cxx.exp 2017-04-20 22:27:49.955050293 +0200
624 +gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
625 +gdb_continue_to_breakpoint "Before pointer assignment"
626 +gdb_test "ptype ptr" "int \\(\\*\\)\\\[variable length\\\]" "ptype ptr, Before pointer assignment"
627 +gdb_test "print ptr" "\\(int \\(\\*\\)\\\[variable length\\\]\\) 0x0" "print ptr, Before pointer assignment"
628 +gdb_test "print *ptr" "Cannot access memory at address 0x0" "print *ptr, Before pointer assignment"
630 gdb_breakpoint [gdb_get_line_number "vlas_filled"]
631 gdb_continue_to_breakpoint "vlas_filled"
634 # bug being tested, it's better not to depend on the exact spelling.
635 gdb_test "print vlaref2" " = \\(.*\\) @$hex: \\{5, 7, 9\\}"
636 gdb_test "print c" " = \\{e = \\{c = @$hex\\}\\}"
637 +gdb_test "ptype ptr" "int \\(\\*\\)\\\[3\\\]"
638 +gdb_test "print ptr" "\\(int \\(\\*\\)\\\[3\\\]\\) $hex"
639 +gdb_test "print *ptr" " = \\{5, 7, 9\\}"
640 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/pointers.exp
641 ===================================================================
642 --- /dev/null 1970-01-01 00:00:00.000000000 +0000
643 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/pointers.exp 2017-04-20 22:27:49.955050293 +0200
645 +# Copyright 2016 Free Software Foundation, Inc.
647 +# This program is free software; you can redistribute it and/or modify
648 +# it under the terms of the GNU General Public License as published by
649 +# the Free Software Foundation; either version 3 of the License, or
650 +# (at your option) any later version.
652 +# This program is distributed in the hope that it will be useful,
653 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
654 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
655 +# GNU General Public License for more details.
657 +# You should have received a copy of the GNU General Public License
658 +# along with this program. If not, see <http://www.gnu.org/licenses/>.
660 +standard_testfile "pointers.f90"
661 +load_lib fortran.exp
663 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
664 + {debug f90 quiet}] } {
669 + untested "could not run to main"
673 +# Depending on the compiler being used, the type names can be printed differently.
674 +set logical [fortran_logical4]
675 +set real [fortran_real4]
676 +set int [fortran_int4]
677 +set complex [fortran_complex4]
680 +gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
681 +gdb_continue_to_breakpoint "Before pointer assignment"
682 +gdb_test "print logp" "= \\(PTR TO -> \\( $logical \\)\\) 0x0" "print logp, not associated"
683 +gdb_test "print *logp" "Cannot access memory at address 0x0" "print *logp, not associated"
684 +gdb_test "print comp" "= \\(PTR TO -> \\( $complex \\)\\) 0x0" "print comp, not associated"
685 +gdb_test "print *comp" "Cannot access memory at address 0x0" "print *comp, not associated"
686 +gdb_test "print charp" "= \\(PTR TO -> \\( character\\*1 \\)\\) 0x0" "print charp, not associated"
687 +gdb_test "print *charp" "Cannot access memory at address 0x0" "print *charp, not associated"
688 +gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3 \\)\\) 0x0" "print charap, not associated"
689 +gdb_test "print *charap" "Cannot access memory at address 0x0" "print *charap, not associated"
690 +gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0" "print intp, not associated"
691 +gdb_test "print *intp" "Cannot access memory at address 0x0" "print *intp, not associated"
692 +set test "print intap, not associated"
693 +gdb_test_multiple "print intap" $test {
694 + -re " = \\(PTR TO -> \\( $int \\(:,:\\)\\)\\) <not associated>\r\n$gdb_prompt $" {
697 + -re " = <not associated>\r\n$gdb_prompt $" {
701 +gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) 0x0" "print realp, not associated"
702 +gdb_test "print *realp" "Cannot access memory at address 0x0" "print *realp, not associated"
703 +gdb_test "print \$my_var = intp" "= \\(PTR TO -> \\( $int \\)\\) 0x0"
704 +set test "print cyclicp1, not associated"
705 +gdb_test_multiple "print cyclicp1" $test {
706 + -re "= \\( i = -?\\d+, p = 0x0 \\)\r\n$gdb_prompt $" {
709 + -re "= \\( i = -?\\d+, p = <not associated> \\)\r\n$gdb_prompt $" {
713 +set test "print cyclicp1%p, not associated"
714 +gdb_test_multiple "print cyclicp1%p" $test {
715 + -re "= \\(PTR TO -> \\( Type typewithpointer \\)\\) 0x0\r\n$gdb_prompt $" {
718 + -re "= \\(PTR TO -> \\( Type typewithpointer \\)\\) <not associated>\r\n$gdb_prompt $" {
724 +gdb_breakpoint [gdb_get_line_number "Before value assignment"]
725 +gdb_continue_to_breakpoint "Before value assignment"
726 +gdb_test "print *(twop)%ivla2" "= <not allocated>"
729 +gdb_breakpoint [gdb_get_line_number "After value assignment"]
730 +gdb_continue_to_breakpoint "After value assignment"
731 +gdb_test "print logp" "= \\(PTR TO -> \\( $logical \\)\\) $hex\( <.*>\)?"
732 +gdb_test "print *logp" "= \\.TRUE\\."
733 +gdb_test "print comp" "= \\(PTR TO -> \\( $complex \\)\\) $hex\( <.*>\)?"
734 +gdb_test "print *comp" "= \\(1,2\\)"
735 +gdb_test "print charp" "= \\(PTR TO -> \\( character\\*1 \\)\\) $hex\( <.*>\)?"
736 +gdb_test "print *charp" "= 'a'"
737 +gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\( <.*>\)?"
738 +gdb_test "print *charap" "= 'abc'"
739 +gdb_test "print intp" "= \\(PTR TO -> \\( $int \\)\\) $hex\( <.*>\)?"
740 +gdb_test "print *intp" "= 10"
741 +set test_name "print intap, associated"
742 +gdb_test_multiple "print intap" $test_name {
743 + -re "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)\r\n$gdb_prompt $" {
746 + -re "= \\(PTR TO -> \\( $int \\(10,2\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
747 + gdb_test "print *intap" "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)"
751 +set test_name "print intvlap, associated"
752 +gdb_test_multiple "print intvlap" $test_name {
753 + -re "= \\(2, 2, 2, 4(, 2){6}\\)\r\n$gdb_prompt $" {
756 + -re "= \\(PTR TO -> \\( $int \\(10\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" {
757 + gdb_test "print *intvlap" "= \\(2, 2, 2, 4(, 2){6}\\)"
761 +gdb_test "print realp" "= \\(PTR TO -> \\( $real \\)\\) $hex\( <.*>\)?"
762 +gdb_test "print *realp" "= 3\\.14000\\d+"
763 +gdb_test "print arrayOfPtr(2)%p" "= \\(PTR TO -> \\( Type two \\)\\) $hex\( <.*>\)?"
764 +gdb_test "print *(arrayOfPtr(2)%p)" "= \\( ivla1 = \\(11, 12, 13\\), ivla2 = \\(\\( 211, 221\\) \\( 212, 222\\) \\) \\)"
765 +set test_name "print arrayOfPtr(3)%p"
766 +gdb_test_multiple $test_name $test_name {
767 + -re "= \\(PTR TO -> \\( Type two \\)\\) <not associated>\r\n$gdb_prompt $" {
770 + -re "= \\(PTR TO -> \\( Type two \\)\\) 0x0\r\n$gdb_prompt $" {
774 +set test_name "print *(arrayOfPtr(3)%p), associated"
775 +gdb_test_multiple "print *(arrayOfPtr(3)%p)" $test_name {
776 + -re "Cannot access memory at address 0x0\r\n$gdb_prompt $" {
779 + -re "Attempt to take contents of a not associated pointer.\r\n$gdb_prompt $" {
783 +gdb_test "print cyclicp1" "= \\( i = 1, p = $hex\( <.*>\)? \\)"
784 +gdb_test "print cyclicp1%p" "= \\(PTR TO -> \\( Type typewithpointer \\)\\) $hex\( <.*>\)?"
785 +gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array"
786 +gdb_test "print *((integer*) &intvla + 3)" "= 4" "print temporary pointer, allocated vla"
787 +gdb_test "print \$pc" "= \\(PTR TO -> \\( void \\(\\)\\(\\)\\)\\) $hex <pointers\\+\\d+>" "Print program counter"
788 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/pointers.f90
789 ===================================================================
790 --- /dev/null 1970-01-01 00:00:00.000000000 +0000
791 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/pointers.f90 2017-04-20 22:27:49.955050293 +0200
793 +! Copyright 2016 Free Software Foundation, Inc.
795 +! This program is free software; you can redistribute it and/or modify
796 +! it under the terms of the GNU General Public License as published by
797 +! the Free Software Foundation; either version 3 of the License, or
798 +! (at your option) any later version.
800 +! This program is distributed in the hope that it will be useful,
801 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
802 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
803 +! GNU General Public License for more details.
805 +! You should have received a copy of the GNU General Public License
806 +! along with this program. If not, see <http://www.gnu.org/licenses/>.
811 + integer, allocatable :: ivla1 (:)
812 + integer, allocatable :: ivla2 (:, :)
815 + type :: typeWithPointer
817 + type(typeWithPointer), pointer:: p
818 + end type typeWithPointer
821 + type (two), pointer :: p
824 + logical, target :: logv
825 + complex, target :: comv
826 + character, target :: charv
827 + character (len=3), target :: chara
828 + integer, target :: intv
829 + integer, target, dimension (10,2) :: inta
830 + integer, target, allocatable, dimension (:) :: intvla
831 + real, target :: realv
832 + type(two), target :: twov
833 + type(twoPtr) :: arrayOfPtr (3)
834 + type(typeWithPointer), target:: cyclicp1,cyclicp2
836 + logical, pointer :: logp
837 + complex, pointer :: comp
838 + character, pointer:: charp
839 + character (len=3), pointer:: charap
840 + integer, pointer :: intp
841 + integer, pointer, dimension (:,:) :: intap
842 + integer, pointer, dimension (:) :: intvlap
843 + real, pointer :: realp
844 + type(two), pointer :: twop
855 + nullify (arrayOfPtr(1)%p)
856 + nullify (arrayOfPtr(2)%p)
857 + nullify (arrayOfPtr(3)%p)
858 + nullify (cyclicp1%p)
859 + nullify (cyclicp2%p)
861 + logp => logv ! Before pointer assignment
870 + arrayOfPtr(2)%p => twov
872 + cyclicp1%p => cyclicp2
874 + cyclicp2%p => cyclicp1
876 + logv = associated(logp) ! Before value assignment
883 + allocate (intvla(10))
889 + allocate (twov%ivla1(3))
890 + allocate (twov%ivla2(2,2))
894 + twov%ivla2(1,1) = 211
895 + twov%ivla2(2,1) = 221
896 + twov%ivla2(1,2) = 212
897 + twov%ivla2(2,2) = 222
899 + intv = intv + 1 ! After value assignment
901 +end program pointers
902 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/print_type.exp
903 ===================================================================
904 --- /dev/null 1970-01-01 00:00:00.000000000 +0000
905 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/print_type.exp 2017-04-20 22:27:49.956050299 +0200
907 +# Copyright 2016 Free Software Foundation, Inc.
909 +# This program is free software; you can redistribute it and/or modify
910 +# it under the terms of the GNU General Public License as published by
911 +# the Free Software Foundation; either version 3 of the License, or
912 +# (at your option) any later version.
914 +# This program is distributed in the hope that it will be useful,
915 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
916 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
917 +# GNU General Public License for more details.
919 +# You should have received a copy of the GNU General Public License
920 +# along with this program. If not, see <http://www.gnu.org/licenses/>.
922 +standard_testfile "pointers.f90"
923 +load_lib fortran.exp
925 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
926 + {debug f90 quiet}] } {
932 + untested "could not run to main"
936 +# Depending on the compiler being used, the type names can be printed differently.
937 +set logical [fortran_logical4]
938 +set real [fortran_real4]
939 +set int [fortran_int4]
940 +set complex [fortran_complex4]
942 +gdb_breakpoint [gdb_get_line_number "Before pointer assignment"]
943 +gdb_continue_to_breakpoint "Before pointer assignment"
944 +gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)" "ptype logp, not associated"
945 +gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)" "ptype comp, not associated"
946 +gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)" "ptype charp, not associated"
947 +gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)" "ptype charap, not associated"
948 +gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)" "ptype intp, not associated"
949 +set test "ptype intap, not associated"
950 +gdb_test_multiple "ptype intap" $test {
951 + -re "type = PTR TO -> \\( $int \\(:,:\\)\\)\r\n$gdb_prompt $" {
954 + -re "type = $int \\(:,:\\)\r\n$gdb_prompt $" {
958 +gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)" "ptype realp, not associated"
959 +gdb_test "ptype twop" \
960 + [multi_line "type = PTR TO -> \\( Type two" \
961 + " $int :: ivla1\\(:\\)" \
962 + " $int :: ivla2\\(:,:\\)" \
963 + "End Type two \\)"] \
964 + "ptype twop, not associated"
965 +gdb_test "ptype two" \
966 + [multi_line "type = Type two" \
967 + " $int :: ivla1\\(:\\)" \
968 + " $int :: ivla2\\(:,:\\)" \
972 +gdb_breakpoint [gdb_get_line_number "Before value assignment"]
973 +gdb_continue_to_breakpoint "Before value assignment"
974 +gdb_test "ptype twop" \
975 + [multi_line "type = PTR TO -> \\( Type two" \
976 + " $int :: ivla1\\(:\\)" \
977 + " $int :: ivla2\\(:,:\\)" \
978 + "End Type two \\)"]
981 +gdb_breakpoint [gdb_get_line_number "After value assignment"]
982 +gdb_continue_to_breakpoint "After value assignment"
983 +gdb_test "ptype logv" "type = $logical"
984 +gdb_test "ptype comv" "type = $complex"
985 +gdb_test "ptype charv" "type = character\\*1"
986 +gdb_test "ptype chara" "type = character\\*3"
987 +gdb_test "ptype intv" "type = $int"
988 +gdb_test "ptype inta" "type = $int \\(10,2\\)"
989 +gdb_test "ptype realv" "type = $real"
992 +gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)"
993 +gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)"
994 +gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)"
995 +gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)"
996 +gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)"
997 +set test "ptype intap"
998 +gdb_test_multiple $test $test {
999 + -re "type = $int \\(10,2\\)\r\n$gdb_prompt $" {
1002 + -re "type = PTR TO -> \\( $int \\(10,2\\)\\)\r\n$gdb_prompt $" {
1006 +gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)"
1007 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-ptype.exp
1008 ===================================================================
1009 --- gdb-7.99.90.20170420.orig/gdb/testsuite/gdb.fortran/vla-ptype.exp 2017-04-20 22:27:47.094032225 +0200
1010 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-ptype.exp 2017-04-20 22:27:49.956050299 +0200
1012 # Check the ptype of various VLA states and pointer to VLA's.
1013 gdb_breakpoint [gdb_get_line_number "vla1-init"]
1014 gdb_continue_to_breakpoint "vla1-init"
1015 -gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not initialized"
1016 -gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not initialized"
1017 -gdb_test "ptype pvla" "type = <not associated>" "ptype pvla not initialized"
1018 +gdb_test "ptype vla1" "type = $real \\(:,:,:\\)" "ptype vla1 not initialized"
1019 +gdb_test "ptype vla2" "type = $real \\(:,:,:\\)" "ptype vla2 not initialized"
1020 +gdb_test "ptype pvla" "type = $real \\(:,:,:\\)" "ptype pvla not initialized"
1021 gdb_test "ptype vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \
1022 "ptype vla1(3, 6, 9) not initialized"
1023 gdb_test "ptype vla2(5, 45, 20)" \
1026 gdb_breakpoint [gdb_get_line_number "pvla-deassociated"]
1027 gdb_continue_to_breakpoint "pvla-deassociated"
1028 -gdb_test "ptype pvla" "type = <not associated>" "ptype pvla deassociated"
1029 +gdb_test "ptype pvla" "type = $real \\(:,:,:\\)" "ptype pvla deassociated"
1030 gdb_test "ptype pvla(5, 45, 20)" \
1031 "no such vector element \\\(vector not associated\\\)" \
1032 "ptype pvla(5, 45, 20) not associated"
1034 gdb_breakpoint [gdb_get_line_number "vla1-deallocated"]
1035 gdb_continue_to_breakpoint "vla1-deallocated"
1036 -gdb_test "ptype vla1" "type = <not allocated>" "ptype vla1 not allocated"
1037 +gdb_test "ptype vla1" "type = $real \\(:,:,:\\)" "ptype vla1 not allocated"
1038 gdb_test "ptype vla1(3, 6, 9)" "no such vector element \\\(vector not allocated\\\)" \
1039 "ptype vla1(3, 6, 9) not allocated"
1041 gdb_breakpoint [gdb_get_line_number "vla2-deallocated"]
1042 gdb_continue_to_breakpoint "vla2-deallocated"
1043 -gdb_test "ptype vla2" "type = <not allocated>" "ptype vla2 not allocated"
1044 +gdb_test "ptype vla2" "type = $real \\(:,:,:\\)" "ptype vla2 not allocated"
1045 gdb_test "ptype vla2(5, 45, 20)" \
1046 "no such vector element \\\(vector not allocated\\\)" \
1047 "ptype vla2(5, 45, 20) not allocated"
1048 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-strings.exp
1049 ===================================================================
1050 --- /dev/null 1970-01-01 00:00:00.000000000 +0000
1051 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-strings.exp 2017-04-20 22:27:49.956050299 +0200
1053 +# Copyright 2016 Free Software Foundation, Inc.
1055 +# This program is free software; you can redistribute it and/or modify
1056 +# it under the terms of the GNU General Public License as published by
1057 +# the Free Software Foundation; either version 3 of the License, or
1058 +# (at your option) any later version.
1060 +# This program is distributed in the hope that it will be useful,
1061 +# but WITHOUT ANY WARRANTY; without even the implied warranty of
1062 +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1063 +# GNU General Public License for more details.
1065 +# You should have received a copy of the GNU General Public License
1066 +# along with this program. If not, see <http://www.gnu.org/licenses/>.
1068 +standard_testfile ".f90"
1070 +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
1071 + {debug f90 quiet}] } {
1075 +# check that all fortran standard datatypes will be
1076 +# handled correctly when using as VLA's
1079 + untested "could not run to main"
1083 +gdb_breakpoint [gdb_get_line_number "var_char-allocated-1"]
1084 +gdb_continue_to_breakpoint "var_char-allocated-1"
1085 +set test "whatis var_char first time"
1086 +gdb_test_multiple "whatis var_char" $test {
1087 + -re "type = PTR TO -> \\( character\\*10 \\)\r\n$gdb_prompt $" {
1090 + -re "type = character\\*10\r\n$gdb_prompt $" {
1094 +set test "ptype var_char first time"
1095 +gdb_test_multiple "ptype var_char" $test {
1096 + -re "type = PTR TO -> \\( character\\*10 \\)\r\n$gdb_prompt $" {
1099 + -re "type = character\\*10\r\n$gdb_prompt $" {
1105 +gdb_test "next" "\\d+.*var_char = 'foo'.*" \
1106 + "next to allocation status of var_char"
1107 +gdb_test "print l" " = \\.TRUE\\." "print allocation status first time"
1110 +gdb_breakpoint [gdb_get_line_number "var_char-filled-1"]
1111 +gdb_continue_to_breakpoint "var_char-filled-1"
1112 +set test "print var_char, var_char-filled-1"
1113 +gdb_test_multiple "print var_char" $test {
1114 + -re "= \\(PTR TO -> \\( character\\*3 \\)\\) $hex\r\n$gdb_prompt $" {
1115 + gdb_test "print *var_char" "= 'foo'" "print *var_char, var_char-filled-1"
1118 + -re "= 'foo'\r\n$gdb_prompt $" {
1122 +set test "ptype var_char, var_char-filled-1"
1123 +gdb_test_multiple "ptype var_char" $test {
1124 + -re "type = PTR TO -> \\( character\\*3 \\)\r\n$gdb_prompt $" {
1127 + -re "type = character\\*3\r\n$gdb_prompt $" {
1131 +gdb_test "print var_char(1)" " = 102 'f'" "print var_char(1)"
1132 +gdb_test "print var_char(3)" " = 111 'o'" "print var_char(3)"
1135 +gdb_breakpoint [gdb_get_line_number "var_char-filled-2"]
1136 +gdb_continue_to_breakpoint "var_char-filled-2"
1137 +set test "print var_char, var_char-filled-2"
1138 +gdb_test_multiple "print var_char" $test {
1139 + -re "= \\(PTR TO -> \\( character\\*6 \\)\\) $hex\r\n$gdb_prompt $" {
1140 + gdb_test "print *var_char" "= 'foobar'" "print *var_char, var_char-filled-2"
1143 + -re "= 'foobar'\r\n$gdb_prompt $" {
1147 +set test "ptype var_char, var_char-filled-2"
1148 +gdb_test_multiple "ptype var_char" $test {
1149 + -re "type = PTR TO -> \\( character\\*6 \\)\r\n$gdb_prompt $" {
1152 + -re "type = character\\*6\r\n$gdb_prompt $" {
1156 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-strings.f90
1157 ===================================================================
1158 --- /dev/null 1970-01-01 00:00:00.000000000 +0000
1159 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-strings.f90 2017-04-20 22:27:49.956050299 +0200
1161 +! Copyright 2016 Free Software Foundation, Inc.
1163 +! This program is free software; you can redistribute it and/or modify
1164 +! it under the terms of the GNU General Public License as published by
1165 +! the Free Software Foundation; either version 3 of the License, or
1166 +! (at your option) any later version.
1168 +! This program is distributed in the hope that it will be useful,
1169 +! but WITHOUT ANY WARRANTY; without even the implied warranty of
1170 +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
1171 +! GNU General Public License for more details.
1173 +! You should have received a copy of the GNU General Public License
1174 +! along with this program. If not, see <http://www.gnu.org/licenses/>.
1176 +program vla_strings
1177 + character(len=:), target, allocatable :: var_char
1178 + character(len=:), pointer :: var_char_p
1181 + allocate(character(len=10) :: var_char)
1182 + l = allocated(var_char) ! var_char-allocated-1
1184 + deallocate(var_char) ! var_char-filled-1
1185 + l = allocated(var_char) ! var_char-deallocated
1186 + allocate(character(len=42) :: var_char)
1187 + l = allocated(var_char)
1188 + var_char = 'foobar'
1189 + var_char = '' ! var_char-filled-2
1190 + var_char = 'bar' ! var_char-empty
1191 + deallocate(var_char)
1192 + allocate(character(len=21) :: var_char)
1193 + l = allocated(var_char) ! var_char-allocated-3
1194 + var_char = 'johndoe'
1195 + var_char_p => var_char
1196 + l = associated(var_char_p) ! var_char_p-associated
1197 + var_char_p => null()
1198 + l = associated(var_char_p) ! var_char_p-not-associated
1199 +end program vla_strings
1200 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-type.exp
1201 ===================================================================
1202 --- gdb-7.99.90.20170420.orig/gdb/testsuite/gdb.fortran/vla-type.exp 2017-04-20 22:27:47.094032225 +0200
1203 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-type.exp 2017-04-20 22:27:49.956050299 +0200
1204 @@ -132,7 +132,10 @@
1207 # Check allocation status of dynamic array and it's dynamic members
1208 -gdb_test "ptype fivedynarr" "type = <not allocated>"
1209 +gdb_test "ptype fivedynarr" \
1210 + [multi_line "type = Type five" \
1211 + " Type one :: tone" \
1212 + "End Type five \\(:\\)" ]
1214 gdb_test "ptype fivedynarr(2)" \
1215 [multi_line "type = Type five" \
1217 "ptype fivedynarr(2), tone is not allocated"
1218 gdb_test "ptype fivedynarr(2)%tone" \
1219 [multi_line "type = Type one" \
1220 - " $int :: ivla\\(<not allocated>\\)" \
1221 + " $int :: ivla\\(:,:,:\\)" \
1223 "ptype fivedynarr(2)%tone, not allocated"
1225 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-value.exp
1226 ===================================================================
1227 --- gdb-7.99.90.20170420.orig/gdb/testsuite/gdb.fortran/vla-value.exp 2017-04-20 22:27:47.095032231 +0200
1228 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.fortran/vla-value.exp 2017-04-20 22:27:49.957050306 +0200
1230 # along with this program. If not, see <http://www.gnu.org/licenses/>.
1232 standard_testfile "vla.f90"
1233 +load_lib "fortran.exp"
1235 if { [prepare_for_testing "failed to prepare" ${testfile} ${srcfile} \
1236 {debug f90 quiet}] } {
1241 +# Depending on the compiler being used, the type names can be printed differently.
1242 +set real [fortran_real4]
1244 # Try to access values in non allocated VLA
1245 gdb_breakpoint [gdb_get_line_number "vla1-init"]
1246 gdb_continue_to_breakpoint "vla1-init"
1247 gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1"
1248 gdb_test "print &vla1" \
1249 - " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(<not allocated>\\\)\\\)\\\) $hex" \
1250 + " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\)\\\)\\\) $hex" \
1251 "print non-allocated &vla1"
1252 gdb_test "print vla1(1,1,1)" "no such vector element \\\(vector not allocated\\\)" \
1253 "print member in non-allocated vla1 (1)"
1255 "step over value assignment of vla1"
1257 gdb_test "print &vla1" \
1258 - " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(10,10,10\\\)\\\)\\\) $hex" \
1259 + " = \\\(PTR TO -> \\\( $real \\\(10,10,10\\\)\\\)\\\) $hex" \
1260 "print allocated &vla1"
1261 gdb_test "print vla1(3, 6, 9)" " = 1311" "print allocated vla1(3,6,9)"
1262 gdb_test "print vla1(1, 3, 8)" " = 1311" "print allocated vla1(1,3,8)"
1264 # Try to access values in undefined pointer to VLA (dangling)
1265 gdb_test "print pvla" " = <not associated>" "print undefined pvla"
1266 gdb_test "print &pvla" \
1267 - " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(<not associated>\\\)\\\)\\\) $hex" \
1268 + " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\)\\\)\\\) $hex" \
1269 "print non-associated &pvla"
1270 gdb_test "print pvla(1, 3, 8)" "no such vector element \\\(vector not associated\\\)" \
1271 "print undefined pvla(1,3,8)"
1273 gdb_breakpoint [gdb_get_line_number "pvla-associated"]
1274 gdb_continue_to_breakpoint "pvla-associated"
1275 gdb_test "print &pvla" \
1276 - " = \\\(PTR TO -> \\\( real\\\(kind=4\\\) \\\(10,10,10\\\)\\\)\\\) $hex" \
1277 + " = \\\(PTR TO -> \\\( $real \\\(10,10,10\\\)\\\)\\\) $hex" \
1278 "print associated &pvla"
1279 gdb_test "print pvla(3, 6, 9)" " = 42" "print associated pvla(3,6,9)"
1280 gdb_test "print pvla(1, 3, 8)" " = 1001" "print associated pvla(1,3,8)"
1281 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.mi/mi-var-child-f.exp
1282 ===================================================================
1283 --- gdb-7.99.90.20170420.orig/gdb/testsuite/gdb.mi/mi-var-child-f.exp 2017-04-20 22:27:47.095032231 +0200
1284 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.mi/mi-var-child-f.exp 2017-04-20 22:27:49.957050306 +0200
1287 load_lib mi-support.exp
1289 +load_lib "fortran.exp"
1291 if { [skip_fortran_tests] } { return -1 }
1294 mi_create_varobj "array" "array" "create local variable array"
1297 -# Depending on the compiler version being used, the name of the 4-byte integer
1298 -# and real types can be printed differently. For instance, gfortran-4.1 uses
1299 -# "int4" whereas gfortran-4.3 uses "integer(kind=4)".
1300 -set int4 "(int4|integer\\(kind=4\\))"
1301 +# Depending on the compiler being used, the type names can be printed differently.
1302 +set int4 [fortran_int4]
1304 set children [list [list "array.-1" "-1" 2 "$int4 \\(2\\)"] \
1305 [list "array.0" "0" 2 "$int4 \\(2\\)"] \
1306 Index: gdb-7.99.90.20170420/gdb/testsuite/gdb.mi/mi-vla-fortran.exp
1307 ===================================================================
1308 --- gdb-7.99.90.20170420.orig/gdb/testsuite/gdb.mi/mi-vla-fortran.exp 2017-04-20 22:27:47.095032231 +0200
1309 +++ gdb-7.99.90.20170420/gdb/testsuite/gdb.mi/mi-vla-fortran.exp 2017-04-20 22:27:49.957050306 +0200
1313 load_lib mi-support.exp
1314 +load_lib fortran.exp
1316 +load_lib "fortran.exp"
1324 +# Depending on the compiler being used, the type names can be printed differently.
1325 +set real [fortran_real4]
1327 mi_delete_breakpoints
1328 mi_gdb_reinitialize_dir $srcdir/$subdir
1329 mi_gdb_load ${binfile}
1331 mi_gdb_test "500-data-evaluate-expression vla1" \
1332 "500\\^done,value=\"<not allocated>\"" "evaluate not allocated vla"
1334 -mi_create_varobj_checked vla1_not_allocated vla1 "<not allocated>" \
1335 +mi_create_varobj_checked vla1_not_allocated vla1 "$real \\(:\\)" \
1336 "create local variable vla1_not_allocated"
1337 mi_gdb_test "501-var-info-type vla1_not_allocated" \
1338 - "501\\^done,type=\"<not allocated>\"" \
1339 + "501\\^done,type=\"$real \\(:\\)\"" \
1340 "info type variable vla1_not_allocated"
1341 mi_gdb_test "502-var-show-format vla1_not_allocated" \
1342 "502\\^done,format=\"natural\"" \
1344 "503\\^done,value=\"\\\[0\\\]\"" \
1345 "eval variable vla1_not_allocated"
1346 mi_list_array_varobj_children_with_index "vla1_not_allocated" "0" "1" \
1347 - "real\\\(kind=4\\\)" "get children of vla1_not_allocated"
1348 + "$real" "get children of vla1_not_allocated"
1353 mi_gdb_test "510-data-evaluate-expression vla1" \
1354 "510\\^done,value=\"\\(.*\\)\"" "evaluate allocated vla"
1356 -mi_create_varobj_checked vla1_allocated vla1 "real\\\(kind=4\\\) \\\(5\\\)" \
1357 +mi_create_varobj_checked vla1_allocated vla1 "$real \\\(5\\\)" \
1358 "create local variable vla1_allocated"
1359 mi_gdb_test "511-var-info-type vla1_allocated" \
1360 - "511\\^done,type=\"real\\\(kind=4\\\) \\\(5\\\)\"" \
1361 + "511\\^done,type=\"$real \\\(5\\\)\"" \
1362 "info type variable vla1_allocated"
1363 mi_gdb_test "512-var-show-format vla1_allocated" \
1364 "512\\^done,format=\"natural\"" \
1366 "513\\^done,value=\"\\\[5\\\]\"" \
1367 "eval variable vla1_allocated"
1368 mi_list_array_varobj_children_with_index "vla1_allocated" "5" "1" \
1369 - "real\\\(kind=4\\\)" "get children of vla1_allocated"
1370 + "$real" "get children of vla1_allocated"
1373 set bp_lineno [gdb_get_line_number "vla1-filled"]
1374 @@ -136,10 +141,10 @@
1375 -re "580\\^done,value=\"<not associated>\".*${mi_gdb_prompt}$" {
1378 - mi_create_varobj_checked pvla2_not_associated pvla2 "<not associated>" \
1379 + mi_create_varobj_checked pvla2_not_associated pvla2 "$real \\(:,:\\)" \
1380 "create local variable pvla2_not_associated"
1381 mi_gdb_test "581-var-info-type pvla2_not_associated" \
1382 - "581\\^done,type=\"<not associated>\"" \
1383 + "581\\^done,type=\"$real \\(:,:\\)\"" \
1384 "info type variable pvla2_not_associated"
1385 mi_gdb_test "582-var-show-format pvla2_not_associated" \
1386 "582\\^done,format=\"natural\"" \
1388 "583\\^done,value=\"\\\[0\\\]\"" \
1389 "eval variable pvla2_not_associated"
1390 mi_list_array_varobj_children_with_index "pvla2_not_associated" "0" "1" \
1391 - "real\\\(kind=4\\\)" "get children of pvla2_not_associated"
1392 + "$real" "get children of pvla2_not_associated"
1394 -re "580\\^error,msg=\"value contents too large \\(\[0-9\]+ bytes\\).*${mi_gdb_prompt}$" {
1395 # Undefined behaviour in gfortran.
1397 "evaluate associated vla"
1399 mi_create_varobj_checked pvla2_associated pvla2 \
1400 - "real\\\(kind=4\\\) \\\(5,2\\\)" "create local variable pvla2_associated"
1401 + "$real \\\(5,2\\\)" "create local variable pvla2_associated"
1402 mi_gdb_test "591-var-info-type pvla2_associated" \
1403 - "591\\^done,type=\"real\\\(kind=4\\\) \\\(5,2\\\)\"" \
1404 + "591\\^done,type=\"$real \\\(5,2\\\)\"" \
1405 "info type variable pvla2_associated"
1406 mi_gdb_test "592-var-show-format pvla2_associated" \
1407 "592\\^done,format=\"natural\"" \
1408 Index: gdb-7.99.90.20170420/gdb/typeprint.c
1409 ===================================================================
1410 --- gdb-7.99.90.20170420.orig/gdb/typeprint.c 2017-04-20 22:27:47.095032231 +0200
1411 +++ gdb-7.99.90.20170420/gdb/typeprint.c 2017-04-20 22:27:49.957050306 +0200
1412 @@ -474,6 +474,25 @@
1413 printf_filtered (" */\n");
1416 + /* Resolve any dynamic target type, as we might print
1417 + additional information about the target.
1418 + For example, in Fortran and C we are printing the dimension of the
1419 + dynamic array the pointer is pointing to. */
1420 + if (TYPE_CODE (type) == TYPE_CODE_PTR
1421 + && is_dynamic_type (type) == 1)
1424 + if (NULL != TYPE_DATA_LOCATION (TYPE_TARGET_TYPE(type)))
1425 + addr = value_address (val);
1427 + addr = value_as_address (val);
1430 + && type_not_associated (type) == 0)
1431 + TYPE_TARGET_TYPE (type) = resolve_dynamic_type (TYPE_TARGET_TYPE (type),
1435 LA_PRINT_TYPE (type, "", gdb_stdout, show, 0, &flags);
1436 printf_filtered ("\n");
1438 Index: gdb-7.99.90.20170420/gdb/valops.c
1439 ===================================================================
1440 --- gdb-7.99.90.20170420.orig/gdb/valops.c 2017-04-20 22:27:47.096032238 +0200
1441 +++ gdb-7.99.90.20170420/gdb/valops.c 2017-04-20 22:27:49.958050312 +0200
1442 @@ -1574,6 +1574,19 @@
1443 if (TYPE_CODE (base_type) == TYPE_CODE_PTR)
1445 struct type *enc_type;
1448 + if (type_not_associated (base_type))
1449 + error (_("Attempt to take contents of a not associated pointer."));
1451 + if (NULL != TYPE_DATA_LOCATION (TYPE_TARGET_TYPE (base_type)))
1452 + addr = value_address (arg1);
1454 + addr = value_as_address (arg1);
1457 + TYPE_TARGET_TYPE (base_type) =
1458 + resolve_dynamic_type (TYPE_TARGET_TYPE (base_type), NULL, addr);
1460 /* We may be pointing to something embedded in a larger object.
1461 Get the real type of the enclosing object. */
1462 @@ -1589,8 +1602,7 @@
1464 /* Retrieve the enclosing object pointed to. */
1465 arg2 = value_at_lazy (enc_type,
1466 - (value_as_address (arg1)
1467 - - value_pointed_to_offset (arg1)));
1468 + (addr - value_pointed_to_offset (arg1)));
1470 enc_type = value_type (arg2);
1471 return readjust_indirect_value_type (arg2, enc_type, base_type, arg1);
1472 Index: gdb-7.99.90.20170420/gdb/valprint.c
1473 ===================================================================
1474 --- gdb-7.99.90.20170420.orig/gdb/valprint.c 2017-04-20 22:25:38.224218378 +0200
1475 +++ gdb-7.99.90.20170420/gdb/valprint.c 2017-04-20 22:27:49.959050318 +0200
1476 @@ -1166,12 +1166,6 @@
1480 - if (type_not_associated (value_type (val)))
1482 - val_print_not_associated (stream);
1486 if (type_not_allocated (value_type (val)))
1488 val_print_not_allocated (stream);