]>
Commit | Line | Data |
---|---|---|
4b0e5c1b AM |
1 | From FEDORA_PATCHES Mon Sep 17 00:00:00 2001 |
2 | From: Fedora GDB patches <invalid@email.com> | |
3 | Date: Fri, 27 Oct 2017 21:07:50 +0200 | |
4 | Subject: gdb-vla-intel-fortran-vla-strings.patch | |
5 | ||
4b0e5c1b AM |
6 | ;;=push |
7 | ||
140f8057 JR |
8 | git diff --stat -p gdb/master...gdb/users/bheckel/fortran-vla-strings |
9 | 0ad7d8d1a3a36c6e04e3b6d37d8825f18d595723 | |
10 | ||
11 | gdb/NEWS | 2 + | |
12 | gdb/c-valprint.c | 22 +++++ | |
13 | gdb/dwarf2read.c | 158 +++++++++++++++++++++++++----- | |
14 | gdb/f-typeprint.c | 93 +++++++++--------- | |
15 | gdb/gdbtypes.c | 44 ++++++++- | |
16 | gdb/testsuite/gdb.cp/vla-cxx.cc | 9 ++ | |
17 | gdb/testsuite/gdb.cp/vla-cxx.exp | 9 ++ | |
18 | gdb/testsuite/gdb.fortran/pointers.exp | 143 +++++++++++++++++++++++++++ | |
19 | gdb/testsuite/gdb.fortran/pointers.f90 | 109 +++++++++++++++++++++ | |
20 | gdb/testsuite/gdb.fortran/print_type.exp | 100 +++++++++++++++++++ | |
21 | gdb/testsuite/gdb.fortran/vla-ptype.exp | 12 +-- | |
22 | gdb/testsuite/gdb.fortran/vla-strings.exp | 103 +++++++++++++++++++ | |
23 | gdb/testsuite/gdb.fortran/vla-strings.f90 | 39 ++++++++ | |
24 | gdb/testsuite/gdb.fortran/vla-type.exp | 7 +- | |
25 | gdb/testsuite/gdb.fortran/vla-value.exp | 12 ++- | |
26 | gdb/testsuite/gdb.mi/mi-var-child-f.exp | 7 +- | |
27 | gdb/testsuite/gdb.mi/mi-vla-fortran.exp | 27 ++--- | |
28 | gdb/typeprint.c | 19 ++++ | |
29 | gdb/valops.c | 16 ++- | |
30 | gdb/valprint.c | 6 -- | |
31 | 20 files changed, 827 insertions(+), 110 deletions(-) | |
32 | ||
4b0e5c1b | 33 | diff --git a/gdb/NEWS b/gdb/NEWS |
4b0e5c1b AM |
34 | --- a/gdb/NEWS |
35 | +++ b/gdb/NEWS | |
e28f2cc1 | 36 | @@ -805,6 +805,8 @@ SH-5/SH64 running OpenBSD SH-5/SH64 support in sh*-*-openbsd* |
4b0e5c1b AM |
37 | |
38 | *** Changes in GDB 8.1 | |
140f8057 JR |
39 | |
40 | +* Fortran: Support pointers to dynamic types. | |
41 | + | |
4b0e5c1b AM |
42 | * GDB now supports dynamically creating arbitrary register groups specified |
43 | in XML target descriptions. This allows for finer grain grouping of | |
44 | registers on systems with a large amount of registers. | |
45 | diff --git a/gdb/c-valprint.c b/gdb/c-valprint.c | |
4b0e5c1b AM |
46 | --- a/gdb/c-valprint.c |
47 | +++ b/gdb/c-valprint.c | |
e28f2cc1 | 48 | @@ -649,6 +649,28 @@ c_value_print (struct value *val, struct ui_file *stream, |
140f8057 JR |
49 | else |
50 | { | |
51 | /* normal case */ | |
52 | + if (TYPE_CODE (type) == TYPE_CODE_PTR | |
53 | + && 1 == is_dynamic_type (type)) | |
54 | + { | |
55 | + CORE_ADDR addr; | |
56 | + if (NULL != TYPE_DATA_LOCATION (TYPE_TARGET_TYPE (type))) | |
57 | + addr = value_address (val); | |
58 | + else | |
59 | + addr = value_as_address (val); | |
60 | + | |
61 | + /* We resolve the target-type only when the | |
62 | + pointer is associated. */ | |
63 | + if ((addr != 0) | |
64 | + && (0 == type_not_associated (type))) | |
65 | + TYPE_TARGET_TYPE (type) = | |
66 | + resolve_dynamic_type (TYPE_TARGET_TYPE (type), | |
67 | + NULL, addr); | |
68 | + } | |
69 | + else | |
70 | + { | |
71 | + /* Do nothing. References are already resolved from the beginning, | |
72 | + only pointers are resolved when we actual need the target. */ | |
73 | + } | |
74 | fprintf_filtered (stream, "("); | |
75 | type_print (value_type (val), "", stream, -1); | |
76 | fprintf_filtered (stream, ") "); | |
4b0e5c1b | 77 | diff --git a/gdb/dwarf2read.c b/gdb/dwarf2read.c |
4b0e5c1b AM |
78 | --- a/gdb/dwarf2read.c |
79 | +++ b/gdb/dwarf2read.c | |
e28f2cc1 | 80 | @@ -1827,7 +1827,10 @@ static void read_signatured_type (struct signatured_type *); |
140f8057 JR |
81 | |
82 | static int attr_to_dynamic_prop (const struct attribute *attr, | |
83 | struct die_info *die, struct dwarf2_cu *cu, | |
e28f2cc1 AM |
84 | - struct dynamic_prop *prop, struct type *type); |
85 | + struct dynamic_prop *prop, | |
86 | + struct type *default_type, | |
87 | + const gdb_byte *additional_data, | |
140f8057 JR |
88 | + int additional_data_size); |
89 | ||
90 | /* memory allocation interface */ | |
91 | ||
e28f2cc1 | 92 | @@ -13799,7 +13802,7 @@ read_func_scope (struct die_info *die, struct dwarf2_cu *cu) |
140f8057 JR |
93 | newobj->static_link |
94 | = XOBNEW (&objfile->objfile_obstack, struct dynamic_prop); | |
e28f2cc1 AM |
95 | attr_to_dynamic_prop (attr, die, cu, newobj->static_link, |
96 | - dwarf2_per_cu_addr_type (cu->per_cu)); | |
97 | + dwarf2_per_cu_addr_type (cu->per_cu), NULL, 0); | |
140f8057 JR |
98 | } |
99 | ||
77d10998 | 100 | cu->list_in_scope = cu->get_builder ()->get_local_symbols (); |
e28f2cc1 | 101 | @@ -16565,7 +16568,7 @@ read_array_type (struct die_info *die, struct dwarf2_cu *cu) |
4b0e5c1b AM |
102 | byte_stride_prop |
103 | = (struct dynamic_prop *) alloca (sizeof (struct dynamic_prop)); | |
e28f2cc1 AM |
104 | stride_ok = attr_to_dynamic_prop (attr, die, cu, byte_stride_prop, |
105 | - prop_type); | |
106 | + prop_type, NULL, 0); | |
4b0e5c1b AM |
107 | if (!stride_ok) |
108 | { | |
ed003b1c | 109 | complaint (_("unable to read array DW_AT_byte_stride " |
e28f2cc1 | 110 | @@ -17325,7 +17328,7 @@ read_tag_string_type (struct die_info *die, struct dwarf2_cu *cu) |
140f8057 | 111 | struct attribute *attr; |
e28f2cc1 AM |
112 | struct dynamic_prop prop; |
113 | bool length_is_constant = true; | |
114 | - LONGEST length; | |
115 | + ULONGEST length = UINT_MAX; | |
116 | ||
117 | /* There are a couple of places where bit sizes might be made use of | |
118 | when parsing a DW_TAG_string_type, however, no producer that we know | |
119 | @@ -17346,6 +17349,10 @@ read_tag_string_type (struct die_info *die, struct dwarf2_cu *cu) | |
120 | } | |
121 | } | |
122 | ||
140f8057 JR |
123 | + index_type = objfile_type (objfile)->builtin_int; |
124 | + range_type = create_static_range_type (NULL, index_type, 1, length); | |
e28f2cc1 | 125 | + |
140f8057 JR |
126 | + /* If DW_AT_string_length is defined, the length is stored in memory. */ |
127 | attr = dwarf2_attr (die, DW_AT_string_length, cu); | |
e28f2cc1 AM |
128 | if (attr != nullptr && !attr_form_is_constant (attr)) |
129 | { | |
130 | @@ -17372,13 +17379,71 @@ read_tag_string_type (struct die_info *die, struct dwarf2_cu *cu) | |
131 | } | |
132 | ||
133 | /* Convert the attribute into a dynamic property. */ | |
134 | - if (!attr_to_dynamic_prop (attr, die, cu, &prop, prop_type)) | |
135 | + if (!attr_to_dynamic_prop (attr, die, cu, &prop, prop_type, NULL, 0)) | |
136 | length = 1; | |
137 | else | |
138 | length_is_constant = false; | |
139 | } | |
140 | else if (attr != nullptr) | |
140f8057 | 141 | { |
140f8057 JR |
142 | + if (attr_form_is_block (attr)) |
143 | + { | |
144 | + struct attribute *byte_size, *bit_size; | |
145 | + struct dynamic_prop high; | |
146 | + | |
147 | + byte_size = dwarf2_attr (die, DW_AT_byte_size, cu); | |
148 | + bit_size = dwarf2_attr (die, DW_AT_bit_size, cu); | |
149 | + | |
150 | + /* DW_AT_byte_size should never occur in combination with | |
151 | + DW_AT_bit_size. */ | |
152 | + if (byte_size != NULL && bit_size != NULL) | |
ed003b1c | 153 | + complaint (_("DW_AT_byte_size AND " |
140f8057 JR |
154 | + "DW_AT_bit_size found together at the same time.")); |
155 | + | |
156 | + /* If DW_AT_string_length AND DW_AT_byte_size exist together, | |
157 | + DW_AT_byte_size describes the number of bytes that should be read | |
158 | + from the length memory location. */ | |
159 | + if (byte_size != NULL) | |
160 | + { | |
161 | + /* Build new dwarf2_locexpr_baton structure with additions to the | |
162 | + data attribute, to reflect DWARF specialities to get address | |
163 | + sizes. */ | |
164 | + const gdb_byte append_ops[] = | |
165 | + { | |
166 | + /* DW_OP_deref_size: size of an address on the target machine | |
167 | + (bytes), where the size will be specified by the next | |
168 | + operand. */ | |
169 | + DW_OP_deref_size, | |
170 | + /* Operand for DW_OP_deref_size. */ | |
77d10998 | 171 | + (gdb_byte) DW_UNSND(byte_size) }; |
140f8057 | 172 | + |
e28f2cc1 AM |
173 | + if (!attr_to_dynamic_prop (attr, die, cu, &high, index_type, |
174 | + append_ops, ARRAY_SIZE(append_ops))) | |
ed003b1c | 175 | + complaint (_("Could not parse DW_AT_byte_size")); |
140f8057 JR |
176 | + } |
177 | + else if (bit_size != NULL) | |
ed003b1c | 178 | + complaint (_("DW_AT_string_length AND " |
140f8057 JR |
179 | + "DW_AT_bit_size found but not supported yet.")); |
180 | + /* If DW_AT_string_length WITHOUT DW_AT_byte_size exist, the default | |
181 | + is the address size of the target machine. */ | |
182 | + else | |
183 | + { | |
184 | + const gdb_byte append_ops[] = | |
185 | + { DW_OP_deref }; | |
186 | + | |
e28f2cc1 AM |
187 | + if (!attr_to_dynamic_prop (attr, die, cu, &high, index_type, |
188 | + append_ops, ARRAY_SIZE(append_ops))) | |
ed003b1c | 189 | + complaint (_("Could not parse DW_AT_string_length")); |
140f8057 JR |
190 | + } |
191 | + | |
192 | + TYPE_RANGE_DATA (range_type)->high = high; | |
193 | + } | |
194 | + else | |
195 | + { | |
196 | + TYPE_HIGH_BOUND (range_type) = DW_UNSND(attr); | |
197 | + TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST; | |
198 | + } | |
e28f2cc1 AM |
199 | + |
200 | /* This DW_AT_string_length just contains the length with no | |
201 | indirection. There's no need to create a dynamic property in this | |
202 | case. Pass 0 for the default value as we know it will not be | |
203 | @@ -17392,6 +17457,20 @@ read_tag_string_type (struct die_info *die, struct dwarf2_cu *cu) | |
140f8057 JR |
204 | } |
205 | else | |
206 | { | |
140f8057 JR |
207 | + /* Check for the DW_AT_byte_size attribute, which represents the length |
208 | + in this case. */ | |
e28f2cc1 AM |
209 | + attr = dwarf2_attr (die, DW_AT_byte_size, cu); |
210 | + if (attr) | |
140f8057 JR |
211 | + { |
212 | + TYPE_HIGH_BOUND (range_type) = DW_UNSND(attr); | |
213 | + TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST; | |
214 | + } | |
e28f2cc1 | 215 | + else |
140f8057 JR |
216 | + { |
217 | + TYPE_HIGH_BOUND (range_type) = 1; | |
218 | + TYPE_HIGH_BOUND_KIND (range_type) = PROP_CONST; | |
219 | + } | |
e28f2cc1 AM |
220 | + |
221 | /* Use 1 as a fallback length if we have nothing else. */ | |
222 | length = 1; | |
140f8057 | 223 | } |
e28f2cc1 AM |
224 | @@ -17407,6 +17486,7 @@ read_tag_string_type (struct die_info *die, struct dwarf2_cu *cu) |
225 | low_bound.data.const_val = 1; | |
226 | range_type = create_range_type (NULL, index_type, &low_bound, &prop, 0); | |
227 | } | |
228 | + | |
140f8057 JR |
229 | char_type = language_string_char_type (cu->language_defn, gdbarch); |
230 | type = create_string_type (NULL, char_type, range_type); | |
231 | ||
e28f2cc1 | 232 | @@ -17858,7 +17938,8 @@ read_base_type (struct die_info *die, struct dwarf2_cu *cu) |
140f8057 JR |
233 | static int |
234 | attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die, | |
e28f2cc1 AM |
235 | struct dwarf2_cu *cu, struct dynamic_prop *prop, |
236 | - struct type *default_type) | |
237 | + struct type *default_type, | |
140f8057 JR |
238 | + const gdb_byte *additional_data, int additional_data_size) |
239 | { | |
240 | struct dwarf2_property_baton *baton; | |
ed003b1c | 241 | struct obstack *obstack |
e28f2cc1 AM |
242 | @@ -17885,9 +17966,30 @@ attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die, |
243 | baton->locexpr.is_reference = false; | |
244 | break; | |
245 | } | |
140f8057 JR |
246 | + |
247 | + if (additional_data != NULL && additional_data_size > 0) | |
248 | + { | |
249 | + gdb_byte *data; | |
250 | + | |
251 | + data = (gdb_byte *) obstack_alloc( | |
ed003b1c | 252 | + &cu->per_cu->dwarf2_per_objfile->objfile->objfile_obstack, |
140f8057 JR |
253 | + DW_BLOCK (attr)->size + additional_data_size); |
254 | + memcpy (data, DW_BLOCK (attr)->data, DW_BLOCK (attr)->size); | |
255 | + memcpy (data + DW_BLOCK (attr)->size, additional_data, | |
256 | + additional_data_size); | |
257 | + | |
258 | + baton->locexpr.data = data; | |
259 | + baton->locexpr.size = DW_BLOCK (attr)->size + additional_data_size; | |
260 | + } | |
261 | + else | |
262 | + { | |
263 | + baton->locexpr.data = DW_BLOCK (attr)->data; | |
264 | + baton->locexpr.size = DW_BLOCK (attr)->size; | |
265 | + } | |
266 | + | |
267 | prop->data.baton = baton; | |
268 | prop->kind = PROP_LOCEXPR; | |
269 | - gdb_assert (prop->data.baton != NULL); | |
270 | + gdb_assert(prop->data.baton != NULL); | |
271 | } | |
272 | else if (attr_form_is_ref (attr)) | |
273 | { | |
e28f2cc1 | 274 | @@ -17920,9 +18022,29 @@ attr_to_dynamic_prop (const struct attribute *attr, struct die_info *die, |
140f8057 | 275 | baton = XOBNEW (obstack, struct dwarf2_property_baton); |
e28f2cc1 | 276 | baton->property_type = die_type (target_die, target_cu); |
140f8057 JR |
277 | baton->locexpr.per_cu = cu->per_cu; |
278 | - baton->locexpr.size = DW_BLOCK (target_attr)->size; | |
279 | - baton->locexpr.data = DW_BLOCK (target_attr)->data; | |
e28f2cc1 | 280 | baton->locexpr.is_reference = true; |
140f8057 JR |
281 | + |
282 | + if (additional_data != NULL && additional_data_size > 0) | |
283 | + { | |
284 | + gdb_byte *data; | |
285 | + | |
ed003b1c | 286 | + data = (gdb_byte *) obstack_alloc (&cu->per_cu->dwarf2_per_objfile->objfile->objfile_obstack, |
140f8057 JR |
287 | + DW_BLOCK (target_attr)->size + additional_data_size); |
288 | + memcpy (data, DW_BLOCK (target_attr)->data, | |
289 | + DW_BLOCK (target_attr)->size); | |
290 | + memcpy (data + DW_BLOCK (target_attr)->size, | |
291 | + additional_data, additional_data_size); | |
292 | + | |
293 | + baton->locexpr.data = data; | |
294 | + baton->locexpr.size = (DW_BLOCK (target_attr)->size | |
295 | + + additional_data_size); | |
296 | + } | |
297 | + else | |
298 | + { | |
299 | + baton->locexpr.data = DW_BLOCK (target_attr)->data; | |
300 | + baton->locexpr.size = DW_BLOCK (target_attr)->size; | |
301 | + } | |
302 | + | |
303 | prop->data.baton = baton; | |
304 | prop->kind = PROP_LOCEXPR; | |
305 | gdb_assert (prop->data.baton != NULL); | |
e28f2cc1 AM |
306 | @@ -18099,8 +18221,8 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu) |
307 | } | |
140f8057 JR |
308 | |
309 | attr = dwarf2_attr (die, DW_AT_lower_bound, cu); | |
e28f2cc1 AM |
310 | - if (attr != nullptr) |
311 | - attr_to_dynamic_prop (attr, die, cu, &low, base_type); | |
312 | + if (attr) | |
313 | + attr_to_dynamic_prop (attr, die, cu, &low, base_type, NULL, 0); | |
140f8057 | 314 | else if (!low_default_is_valid) |
ed003b1c AM |
315 | complaint (_("Missing DW_AT_lower_bound " |
316 | "- DIE at %s [in module %s]"), | |
e28f2cc1 | 317 | @@ -18109,10 +18231,10 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu) |
140f8057 | 318 | |
77d10998 AM |
319 | struct attribute *attr_ub, *attr_count; |
320 | attr = attr_ub = dwarf2_attr (die, DW_AT_upper_bound, cu); | |
e28f2cc1 AM |
321 | - if (!attr_to_dynamic_prop (attr, die, cu, &high, base_type)) |
322 | + if (!attr_to_dynamic_prop (attr, die, cu, &high, base_type, NULL, 0)) | |
140f8057 | 323 | { |
77d10998 | 324 | attr = attr_count = dwarf2_attr (die, DW_AT_count, cu); |
e28f2cc1 AM |
325 | - if (attr_to_dynamic_prop (attr, die, cu, &high, base_type)) |
326 | + if (attr_to_dynamic_prop (attr, die, cu, &high, base_type, NULL, 0)) | |
140f8057 JR |
327 | { |
328 | /* If bounds are constant do the final calculation here. */ | |
329 | if (low.kind == PROP_CONST && high.kind == PROP_CONST) | |
e28f2cc1 AM |
330 | @@ -18164,7 +18286,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu) |
331 | struct type *prop_type | |
332 | = dwarf2_per_cu_addr_sized_int_type (cu->per_cu, false); | |
333 | attr_to_dynamic_prop (attr_byte_stride, die, cu, &byte_stride_prop, | |
334 | - prop_type); | |
335 | + prop_type, NULL, 0); | |
336 | } | |
337 | ||
338 | struct dynamic_prop bit_stride_prop; | |
339 | @@ -18185,7 +18307,7 @@ read_subrange_type (struct die_info *die, struct dwarf2_cu *cu) | |
340 | struct type *prop_type | |
341 | = dwarf2_per_cu_addr_sized_int_type (cu->per_cu, false); | |
342 | attr_to_dynamic_prop (attr_bit_stride, die, cu, &bit_stride_prop, | |
343 | - prop_type); | |
344 | + prop_type, NULL, 0); | |
345 | } | |
346 | } | |
347 | ||
348 | @@ -25879,7 +26001,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu) | |
140f8057 | 349 | { |
e28f2cc1 AM |
350 | struct type *prop_type |
351 | = dwarf2_per_cu_addr_sized_int_type (cu->per_cu, false); | |
352 | - if (attr_to_dynamic_prop (attr, die, cu, &prop, prop_type)) | |
353 | + if (attr_to_dynamic_prop (attr, die, cu, &prop, prop_type, NULL, 0)) | |
ed003b1c | 354 | add_dyn_prop (DYN_PROP_ALLOCATED, prop, type); |
140f8057 JR |
355 | } |
356 | else if (attr != NULL) | |
e28f2cc1 | 357 | @@ -25895,7 +26017,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu) |
140f8057 | 358 | { |
e28f2cc1 AM |
359 | struct type *prop_type |
360 | = dwarf2_per_cu_addr_sized_int_type (cu->per_cu, false); | |
361 | - if (attr_to_dynamic_prop (attr, die, cu, &prop, prop_type)) | |
362 | + if (attr_to_dynamic_prop (attr, die, cu, &prop, prop_type, NULL, 0)) | |
ed003b1c | 363 | add_dyn_prop (DYN_PROP_ASSOCIATED, prop, type); |
140f8057 JR |
364 | } |
365 | else if (attr != NULL) | |
e28f2cc1 | 366 | @@ -25908,7 +26030,7 @@ set_die_type (struct die_info *die, struct type *type, struct dwarf2_cu *cu) |
140f8057 JR |
367 | /* Read DW_AT_data_location and set in type. */ |
368 | attr = dwarf2_attr (die, DW_AT_data_location, cu); | |
e28f2cc1 AM |
369 | if (attr_to_dynamic_prop (attr, die, cu, &prop, |
370 | - dwarf2_per_cu_addr_type (cu->per_cu))) | |
371 | + dwarf2_per_cu_addr_type (cu->per_cu), NULL, 0)) | |
ed003b1c | 372 | add_dyn_prop (DYN_PROP_DATA_LOCATION, prop, type); |
140f8057 JR |
373 | |
374 | if (dwarf2_per_objfile->die_type_hash == NULL) | |
4b0e5c1b | 375 | diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c |
4b0e5c1b AM |
376 | --- a/gdb/f-typeprint.c |
377 | +++ b/gdb/f-typeprint.c | |
e28f2cc1 AM |
378 | @@ -197,15 +197,14 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream, |
379 | print_rank_only = true; | |
380 | else if ((TYPE_ASSOCIATED_PROP (type) | |
381 | && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ASSOCIATED_PROP (type))) | |
382 | - || (TYPE_ALLOCATED_PROP (type) | |
383 | - && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ALLOCATED_PROP (type))) | |
384 | - || (TYPE_DATA_LOCATION (type) | |
385 | - && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_DATA_LOCATION (type)))) | |
386 | - { | |
387 | - /* This case exist when we ptype a typename which has the dynamic | |
388 | - properties but cannot be resolved as there is no object. */ | |
389 | - print_rank_only = true; | |
390 | - } | |
140f8057 JR |
391 | + || (TYPE_ALLOCATED_PROP (type) |
392 | + && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_ALLOCATED_PROP (type))) | |
393 | + || (TYPE_DATA_LOCATION (type) | |
394 | + && PROP_CONST != TYPE_DYN_PROP_KIND (TYPE_DATA_LOCATION (type)))) | |
395 | + /* This case exist when we ptype a typename which has the | |
396 | + dynamic properties but cannot be resolved as there is | |
397 | + no object. */ | |
e28f2cc1 AM |
398 | + print_rank_only = true; |
399 | ||
400 | if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY) | |
401 | f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, | |
402 | @@ -217,8 +216,9 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream, | |
140f8057 | 403 | else |
e28f2cc1 AM |
404 | { |
405 | LONGEST lower_bound = f77_get_lowerbound (type); | |
140f8057 | 406 | + |
e28f2cc1 AM |
407 | if (lower_bound != 1) /* Not the default. */ |
408 | - fprintf_filtered (stream, "%s:", plongest (lower_bound)); | |
409 | + fprintf_filtered (stream, "%s:", plongest (lower_bound)); | |
410 | ||
411 | /* Make sure that, if we have an assumed size array, we | |
412 | print out a warning and print the upperbound as '*'. */ | |
413 | @@ -229,7 +229,7 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream, | |
414 | { | |
415 | LONGEST upper_bound = f77_get_upperbound (type); | |
416 | ||
417 | - fputs_filtered (plongest (upper_bound), stream); | |
418 | + fprintf_filtered (stream, "%s", plongest (upper_bound)); | |
419 | } | |
420 | } | |
421 | ||
422 | @@ -249,7 +249,7 @@ f_type_print_varspec_suffix (struct type *type, struct ui_file *stream, | |
140f8057 JR |
423 | case TYPE_CODE_REF: |
424 | f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0, | |
e28f2cc1 AM |
425 | arrayprint_recurse_level, false); |
426 | - fprintf_filtered (stream, " )"); | |
427 | + fprintf_filtered (stream, ")"); | |
140f8057 JR |
428 | break; |
429 | ||
430 | case TYPE_CODE_FUNC: | |
4b0e5c1b | 431 | diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c |
4b0e5c1b AM |
432 | --- a/gdb/gdbtypes.c |
433 | +++ b/gdb/gdbtypes.c | |
e28f2cc1 | 434 | @@ -1939,7 +1939,8 @@ is_dynamic_type_internal (struct type *type, int top_level) |
140f8057 JR |
435 | type = check_typedef (type); |
436 | ||
437 | /* We only want to recognize references at the outermost level. */ | |
438 | - if (top_level && TYPE_CODE (type) == TYPE_CODE_REF) | |
439 | + if (top_level && | |
440 | + (TYPE_CODE (type) == TYPE_CODE_REF || TYPE_CODE (type) == TYPE_CODE_PTR)) | |
441 | type = check_typedef (TYPE_TARGET_TYPE (type)); | |
442 | ||
443 | /* Types that have a dynamic TYPE_DATA_LOCATION are considered | |
e28f2cc1 AM |
444 | @@ -1972,10 +1973,10 @@ is_dynamic_type_internal (struct type *type, int top_level) |
445 | || is_dynamic_type_internal (TYPE_TARGET_TYPE (type), 0)); | |
140f8057 JR |
446 | } |
447 | ||
e28f2cc1 AM |
448 | - case TYPE_CODE_STRING: |
449 | /* Strings are very much like an array of characters, and can be | |
450 | treated as one here. */ | |
140f8057 JR |
451 | case TYPE_CODE_ARRAY: |
452 | + case TYPE_CODE_STRING: | |
453 | { | |
454 | gdb_assert (TYPE_NFIELDS (type) == 1); | |
455 | ||
e28f2cc1 | 456 | @@ -2139,11 +2140,15 @@ resolve_dynamic_array_or_string (struct type *type, |
140f8057 JR |
457 | |
458 | ary_dim = check_typedef (TYPE_TARGET_TYPE (elt_type)); | |
459 | ||
460 | - if (ary_dim != NULL && TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY) | |
461 | + if (ary_dim != NULL && (TYPE_CODE (ary_dim) == TYPE_CODE_ARRAY | |
462 | + || TYPE_CODE (ary_dim) == TYPE_CODE_STRING)) | |
e28f2cc1 | 463 | elt_type = resolve_dynamic_array_or_string (ary_dim, addr_stack); |
140f8057 JR |
464 | else |
465 | elt_type = TYPE_TARGET_TYPE (type); | |
466 | ||
140f8057 JR |
467 | + if (TYPE_CODE (type) == TYPE_CODE_STRING) |
468 | + return create_string_type (type, elt_type, range_type); | |
4b0e5c1b AM |
469 | + |
470 | prop = get_dyn_prop (DYN_PROP_BYTE_STRIDE, type); | |
471 | if (prop != NULL) | |
472 | { | |
e28f2cc1 | 473 | @@ -2295,6 +2300,28 @@ resolve_dynamic_struct (struct type *type, |
140f8057 JR |
474 | return resolved_type; |
475 | } | |
476 | ||
477 | +/* Worker for pointer types. */ | |
478 | + | |
479 | +static struct type * | |
480 | +resolve_dynamic_pointer (struct type *type, | |
481 | + struct property_addr_info *addr_stack) | |
482 | +{ | |
483 | + struct dynamic_prop *prop; | |
484 | + CORE_ADDR value; | |
485 | + | |
486 | + type = copy_type (type); | |
487 | + | |
488 | + /* Resolve associated property. */ | |
489 | + prop = TYPE_ASSOCIATED_PROP (type); | |
490 | + if (prop != NULL && dwarf2_evaluate_property (prop, NULL, addr_stack, &value)) | |
491 | + { | |
492 | + TYPE_DYN_PROP_ADDR (prop) = value; | |
493 | + TYPE_DYN_PROP_KIND (prop) = PROP_CONST; | |
494 | + } | |
495 | + | |
496 | + return type; | |
497 | +} | |
498 | + | |
499 | /* Worker for resolved_dynamic_type. */ | |
500 | ||
501 | static struct type * | |
e28f2cc1 AM |
502 | @@ -2349,6 +2376,9 @@ resolve_dynamic_type_internal (struct type *type, |
503 | case TYPE_CODE_ARRAY: | |
504 | resolved_type = resolve_dynamic_array_or_string (type, addr_stack); | |
505 | break; | |
140f8057 JR |
506 | + case TYPE_CODE_PTR: |
507 | + resolved_type = resolve_dynamic_pointer (type, addr_stack); | |
508 | + break; | |
140f8057 | 509 | |
e28f2cc1 AM |
510 | case TYPE_CODE_RANGE: |
511 | resolved_type = resolve_dynamic_range (type, addr_stack); | |
4b0e5c1b | 512 | diff --git a/gdb/testsuite/gdb.cp/vla-cxx.cc b/gdb/testsuite/gdb.cp/vla-cxx.cc |
4b0e5c1b AM |
513 | --- a/gdb/testsuite/gdb.cp/vla-cxx.cc |
514 | +++ b/gdb/testsuite/gdb.cp/vla-cxx.cc | |
140f8057 JR |
515 | @@ -15,6 +15,10 @@ |
516 | You should have received a copy of the GNU General Public License | |
517 | along with this program. If not, see <http://www.gnu.org/licenses/>. */ | |
518 | ||
519 | +extern "C" { | |
520 | +#include <stddef.h> | |
521 | +} | |
522 | + | |
523 | struct container; | |
524 | ||
525 | struct element | |
4b0e5c1b | 526 | @@ -40,11 +44,16 @@ int main(int argc, char **argv) |
140f8057 JR |
527 | typedef typeof (vla) &vlareftypedef; |
528 | vlareftypedef vlaref2 (vla); | |
529 | container c; | |
530 | + typeof (vla) *ptr = NULL; | |
531 | + | |
532 | + // Before pointer assignment | |
533 | + ptr = &vla; | |
534 | ||
535 | for (int i = 0; i < z; ++i) | |
536 | vla[i] = 5 + 2 * i; | |
537 | ||
538 | // vlas_filled | |
539 | vla[0] = 2 * vla[0]; | |
540 | + | |
541 | return vla[2]; | |
542 | } | |
4b0e5c1b | 543 | diff --git a/gdb/testsuite/gdb.cp/vla-cxx.exp b/gdb/testsuite/gdb.cp/vla-cxx.exp |
4b0e5c1b AM |
544 | --- a/gdb/testsuite/gdb.cp/vla-cxx.exp |
545 | +++ b/gdb/testsuite/gdb.cp/vla-cxx.exp | |
546 | @@ -23,6 +23,12 @@ if ![runto_main] { | |
140f8057 JR |
547 | return -1 |
548 | } | |
549 | ||
550 | +gdb_breakpoint [gdb_get_line_number "Before pointer assignment"] | |
551 | +gdb_continue_to_breakpoint "Before pointer assignment" | |
552 | +gdb_test "ptype ptr" "int \\(\\*\\)\\\[variable length\\\]" "ptype ptr, Before pointer assignment" | |
553 | +gdb_test "print ptr" "\\(int \\(\\*\\)\\\[variable length\\\]\\) 0x0" "print ptr, Before pointer assignment" | |
554 | +gdb_test "print *ptr" "Cannot access memory at address 0x0" "print *ptr, Before pointer assignment" | |
555 | + | |
556 | gdb_breakpoint [gdb_get_line_number "vlas_filled"] | |
557 | gdb_continue_to_breakpoint "vlas_filled" | |
558 | ||
4b0e5c1b | 559 | @@ -33,3 +39,6 @@ gdb_test "print vlaref" " = \\(int \\(&\\)\\\[3\\\]\\) @$hex: \\{5, 7, 9\\}" |
140f8057 JR |
560 | # bug being tested, it's better not to depend on the exact spelling. |
561 | gdb_test "print vlaref2" " = \\(.*\\) @$hex: \\{5, 7, 9\\}" | |
562 | gdb_test "print c" " = \\{e = \\{c = @$hex\\}\\}" | |
563 | +gdb_test "ptype ptr" "int \\(\\*\\)\\\[3\\\]" | |
564 | +gdb_test "print ptr" "\\(int \\(\\*\\)\\\[3\\\]\\) $hex" | |
565 | +gdb_test "print *ptr" " = \\{5, 7, 9\\}" | |
4b0e5c1b AM |
566 | diff --git a/gdb/testsuite/gdb.fortran/pointers.exp b/gdb/testsuite/gdb.fortran/pointers.exp |
567 | new file mode 100644 | |
4b0e5c1b AM |
568 | --- /dev/null |
569 | +++ b/gdb/testsuite/gdb.fortran/pointers.exp | |
140f8057 JR |
570 | @@ -0,0 +1,143 @@ |
571 | +# Copyright 2016 Free Software Foundation, Inc. | |
572 | + | |
573 | +# This program is free software; you can redistribute it and/or modify | |
574 | +# it under the terms of the GNU General Public License as published by | |
575 | +# the Free Software Foundation; either version 3 of the License, or | |
576 | +# (at your option) any later version. | |
577 | +# | |
578 | +# This program is distributed in the hope that it will be useful, | |
579 | +# but WITHOUT ANY WARRANTY; without even the implied warranty of | |
580 | +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
581 | +# GNU General Public License for more details. | |
582 | +# | |
583 | +# You should have received a copy of the GNU General Public License | |
584 | +# along with this program. If not, see <http://www.gnu.org/licenses/>. | |
585 | + | |
586 | +standard_testfile "pointers.f90" | |
587 | +load_lib fortran.exp | |
588 | + | |
589 | +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ | |
590 | + {debug f90 quiet}] } { | |
591 | + return -1 | |
592 | +} | |
593 | + | |
594 | +if ![runto_main] { | |
595 | + untested "could not run to main" | |
596 | + return -1 | |
597 | +} | |
598 | + | |
599 | +# Depending on the compiler being used, the type names can be printed differently. | |
600 | +set logical [fortran_logical4] | |
601 | +set real [fortran_real4] | |
602 | +set int [fortran_int4] | |
603 | +set complex [fortran_complex4] | |
604 | + | |
605 | + | |
606 | +gdb_breakpoint [gdb_get_line_number "Before pointer assignment"] | |
607 | +gdb_continue_to_breakpoint "Before pointer assignment" | |
e28f2cc1 | 608 | +gdb_test "print logp" "= \\(PTR TO -> \\( $logical\\)\\) 0x0" "print logp, not associated" |
140f8057 | 609 | +gdb_test "print *logp" "Cannot access memory at address 0x0" "print *logp, not associated" |
e28f2cc1 | 610 | +gdb_test "print comp" "= \\(PTR TO -> \\( $complex\\)\\) 0x0" "print comp, not associated" |
140f8057 | 611 | +gdb_test "print *comp" "Cannot access memory at address 0x0" "print *comp, not associated" |
e28f2cc1 | 612 | +gdb_test "print charp" "= \\(PTR TO -> \\( character\\*1\\)\\) 0x0" "print charp, not associated" |
140f8057 | 613 | +gdb_test "print *charp" "Cannot access memory at address 0x0" "print *charp, not associated" |
e28f2cc1 | 614 | +gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3\\)\\) 0x0" "print charap, not associated" |
140f8057 | 615 | +gdb_test "print *charap" "Cannot access memory at address 0x0" "print *charap, not associated" |
e28f2cc1 | 616 | +gdb_test "print intp" "= \\(PTR TO -> \\( $int\\)\\) 0x0" "print intp, not associated" |
140f8057 JR |
617 | +gdb_test "print *intp" "Cannot access memory at address 0x0" "print *intp, not associated" |
618 | +set test "print intap, not associated" | |
619 | +gdb_test_multiple "print intap" $test { | |
620 | + -re " = \\(PTR TO -> \\( $int \\(:,:\\)\\)\\) <not associated>\r\n$gdb_prompt $" { | |
621 | + pass $test | |
622 | + } | |
623 | + -re " = <not associated>\r\n$gdb_prompt $" { | |
624 | + pass $test | |
625 | + } | |
626 | +} | |
e28f2cc1 | 627 | +gdb_test "print realp" "= \\(PTR TO -> \\( $real\\)\\) 0x0" "print realp, not associated" |
140f8057 | 628 | +gdb_test "print *realp" "Cannot access memory at address 0x0" "print *realp, not associated" |
e28f2cc1 | 629 | +gdb_test "print \$my_var = intp" "= \\(PTR TO -> \\( $int\\)\\) 0x0" |
140f8057 JR |
630 | +set test "print cyclicp1, not associated" |
631 | +gdb_test_multiple "print cyclicp1" $test { | |
632 | + -re "= \\( i = -?\\d+, p = 0x0 \\)\r\n$gdb_prompt $" { | |
633 | + pass $test | |
634 | + } | |
635 | + -re "= \\( i = -?\\d+, p = <not associated> \\)\r\n$gdb_prompt $" { | |
636 | + pass $test | |
637 | + } | |
638 | +} | |
639 | +set test "print cyclicp1%p, not associated" | |
640 | +gdb_test_multiple "print cyclicp1%p" $test { | |
e28f2cc1 | 641 | + -re "= \\(PTR TO -> \\( Type typewithpointer\\)\\) 0x0\r\n$gdb_prompt $" { |
140f8057 JR |
642 | + pass $test |
643 | + } | |
e28f2cc1 | 644 | + -re "= \\(PTR TO -> \\( Type typewithpointer\\)\\) <not associated>\r\n$gdb_prompt $" { |
140f8057 JR |
645 | + pass $test |
646 | + } | |
647 | +} | |
648 | + | |
649 | + | |
650 | +gdb_breakpoint [gdb_get_line_number "Before value assignment"] | |
651 | +gdb_continue_to_breakpoint "Before value assignment" | |
652 | +gdb_test "print *(twop)%ivla2" "= <not allocated>" | |
653 | + | |
654 | + | |
655 | +gdb_breakpoint [gdb_get_line_number "After value assignment"] | |
656 | +gdb_continue_to_breakpoint "After value assignment" | |
e28f2cc1 | 657 | +gdb_test "print logp" "= \\(PTR TO -> \\( $logical\\)\\) $hex\( <.*>\)?" |
140f8057 | 658 | +gdb_test "print *logp" "= \\.TRUE\\." |
e28f2cc1 | 659 | +gdb_test "print comp" "= \\(PTR TO -> \\( $complex\\)\\) $hex\( <.*>\)?" |
140f8057 | 660 | +gdb_test "print *comp" "= \\(1,2\\)" |
e28f2cc1 | 661 | +gdb_test "print charp" "= \\(PTR TO -> \\( character\\*1\\)\\) $hex\( <.*>\)?" |
140f8057 | 662 | +gdb_test "print *charp" "= 'a'" |
e28f2cc1 | 663 | +gdb_test "print charap" "= \\(PTR TO -> \\( character\\*3\\)\\) $hex\( <.*>\)?" |
140f8057 | 664 | +gdb_test "print *charap" "= 'abc'" |
e28f2cc1 | 665 | +gdb_test "print intp" "= \\(PTR TO -> \\( $int\\)\\) $hex\( <.*>\)?" |
140f8057 JR |
666 | +gdb_test "print *intp" "= 10" |
667 | +set test_name "print intap, associated" | |
668 | +gdb_test_multiple "print intap" $test_name { | |
669 | + -re "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)\r\n$gdb_prompt $" { | |
670 | + pass $test_name | |
671 | + } | |
672 | + -re "= \\(PTR TO -> \\( $int \\(10,2\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" { | |
673 | + gdb_test "print *intap" "= \\(\\( 1, 1, 3(, 1){7}\\) \\( 1(, 1){9}\\) \\)" | |
674 | + pass $test_name | |
675 | + } | |
676 | +} | |
677 | +set test_name "print intvlap, associated" | |
678 | +gdb_test_multiple "print intvlap" $test_name { | |
679 | + -re "= \\(2, 2, 2, 4(, 2){6}\\)\r\n$gdb_prompt $" { | |
680 | + pass $test_name | |
681 | + } | |
682 | + -re "= \\(PTR TO -> \\( $int \\(10\\)\\)\\) $hex\( <.*>\)?\r\n$gdb_prompt $" { | |
683 | + gdb_test "print *intvlap" "= \\(2, 2, 2, 4(, 2){6}\\)" | |
684 | + pass $test_name | |
685 | + } | |
686 | +} | |
e28f2cc1 | 687 | +gdb_test "print realp" "= \\(PTR TO -> \\( $real\\)\\) $hex\( <.*>\)?" |
140f8057 | 688 | +gdb_test "print *realp" "= 3\\.14000\\d+" |
e28f2cc1 | 689 | +gdb_test "print arrayOfPtr(2)%p" "= \\(PTR TO -> \\( Type two\\)\\) $hex\( <.*>\)?" |
140f8057 JR |
690 | +gdb_test "print *(arrayOfPtr(2)%p)" "= \\( ivla1 = \\(11, 12, 13\\), ivla2 = \\(\\( 211, 221\\) \\( 212, 222\\) \\) \\)" |
691 | +set test_name "print arrayOfPtr(3)%p" | |
692 | +gdb_test_multiple $test_name $test_name { | |
e28f2cc1 | 693 | + -re "= \\(PTR TO -> \\( Type two\\)\\) <not associated>\r\n$gdb_prompt $" { |
140f8057 JR |
694 | + pass $test_name |
695 | + } | |
e28f2cc1 | 696 | + -re "= \\(PTR TO -> \\( Type two\\)\\) 0x0\r\n$gdb_prompt $" { |
140f8057 JR |
697 | + pass $test_name |
698 | + } | |
699 | +} | |
700 | +set test_name "print *(arrayOfPtr(3)%p), associated" | |
701 | +gdb_test_multiple "print *(arrayOfPtr(3)%p)" $test_name { | |
702 | + -re "Cannot access memory at address 0x0\r\n$gdb_prompt $" { | |
703 | + pass $test_name | |
704 | + } | |
705 | + -re "Attempt to take contents of a not associated pointer.\r\n$gdb_prompt $" { | |
706 | + pass $test_name | |
707 | + } | |
708 | +} | |
709 | +gdb_test "print cyclicp1" "= \\( i = 1, p = $hex\( <.*>\)? \\)" | |
e28f2cc1 | 710 | +gdb_test "print cyclicp1%p" "= \\(PTR TO -> \\( Type typewithpointer\\)\\) $hex\( <.*>\)?" |
140f8057 JR |
711 | +gdb_test "print *((integer*) &inta + 2)" "= 3" "print temporary pointer, array" |
712 | +gdb_test "print *((integer*) &intvla + 3)" "= 4" "print temporary pointer, allocated vla" | |
e28f2cc1 | 713 | +gdb_test "print \$pc" "= \\(PTR TO -> \\( void \\(\\) \\(\\)\\)\\) $hex <pointers\\+\\d+>" "Print program counter" |
4b0e5c1b | 714 | diff --git a/gdb/testsuite/gdb.fortran/pointers.f90 b/gdb/testsuite/gdb.fortran/pointers.f90 |
e28f2cc1 | 715 | --- a/gdb/testsuite/gdb.fortran/pointers.f90 |
4b0e5c1b | 716 | +++ b/gdb/testsuite/gdb.fortran/pointers.f90 |
e28f2cc1 AM |
717 | @@ -20,21 +20,34 @@ program pointers |
718 | integer, allocatable :: ivla2 (:, :) | |
719 | end type two | |
720 | ||
140f8057 JR |
721 | + type :: typeWithPointer |
722 | + integer i | |
723 | + type(typeWithPointer), pointer:: p | |
724 | + end type typeWithPointer | |
725 | + | |
726 | + type :: twoPtr | |
727 | + type (two), pointer :: p | |
728 | + end type twoPtr | |
729 | + | |
e28f2cc1 AM |
730 | logical, target :: logv |
731 | complex, target :: comv | |
732 | character, target :: charv | |
733 | character (len=3), target :: chara | |
734 | integer, target :: intv | |
735 | integer, target, dimension (10,2) :: inta | |
736 | - real, target :: realv | |
737 | - type(two), target :: twov | |
140f8057 JR |
738 | + integer, target, allocatable, dimension (:) :: intvla |
739 | + real, target :: realv | |
740 | + type(two), target :: twov | |
741 | + type(twoPtr) :: arrayOfPtr (3) | |
742 | + type(typeWithPointer), target:: cyclicp1,cyclicp2 | |
e28f2cc1 AM |
743 | |
744 | logical, pointer :: logp | |
745 | complex, pointer :: comp | |
746 | - character, pointer :: charp | |
747 | - character (len=3), pointer :: charap | |
140f8057 JR |
748 | + character, pointer:: charp |
749 | + character (len=3), pointer:: charap | |
e28f2cc1 AM |
750 | integer, pointer :: intp |
751 | integer, pointer, dimension (:,:) :: intap | |
140f8057 | 752 | + integer, pointer, dimension (:) :: intvlap |
e28f2cc1 AM |
753 | real, pointer :: realp |
754 | type(two), pointer :: twop | |
755 | ||
756 | @@ -44,8 +57,14 @@ program pointers | |
757 | nullify (charap) | |
758 | nullify (intp) | |
759 | nullify (intap) | |
140f8057 | 760 | + nullify (intvlap) |
e28f2cc1 AM |
761 | nullify (realp) |
762 | nullify (twop) | |
140f8057 JR |
763 | + nullify (arrayOfPtr(1)%p) |
764 | + nullify (arrayOfPtr(2)%p) | |
765 | + nullify (arrayOfPtr(3)%p) | |
766 | + nullify (cyclicp1%p) | |
767 | + nullify (cyclicp2%p) | |
e28f2cc1 AM |
768 | |
769 | logp => logv ! Before pointer assignment | |
770 | comp => comv | |
771 | @@ -53,8 +72,14 @@ program pointers | |
772 | charap => chara | |
773 | intp => intv | |
774 | intap => inta | |
140f8057 | 775 | + intvlap => intvla |
e28f2cc1 AM |
776 | realp => realv |
777 | twop => twov | |
140f8057 JR |
778 | + arrayOfPtr(2)%p => twov |
779 | + cyclicp1%i = 1 | |
780 | + cyclicp1%p => cyclicp2 | |
781 | + cyclicp2%i = 2 | |
782 | + cyclicp2%p => cyclicp1 | |
e28f2cc1 AM |
783 | |
784 | logv = associated(logp) ! Before value assignment | |
785 | comv = cmplx(1,2) | |
786 | @@ -63,6 +88,10 @@ program pointers | |
787 | intv = 10 | |
788 | inta(:,:) = 1 | |
789 | inta(3,1) = 3 | |
140f8057 JR |
790 | + allocate (intvla(10)) |
791 | + intvla(:) = 2 | |
792 | + intvla(4) = 4 | |
793 | + intvlap => intvla | |
e28f2cc1 AM |
794 | realv = 3.14 |
795 | ||
796 | allocate (twov%ivla1(3)) | |
4b0e5c1b | 797 | diff --git a/gdb/testsuite/gdb.fortran/print_type.exp b/gdb/testsuite/gdb.fortran/print_type.exp |
e28f2cc1 | 798 | --- a/gdb/testsuite/gdb.fortran/print_type.exp |
4b0e5c1b | 799 | +++ b/gdb/testsuite/gdb.fortran/print_type.exp |
e28f2cc1 AM |
800 | @@ -1,5 +1,6 @@ |
801 | # Copyright 2019-2020 Free Software Foundation, Inc. | |
802 | # | |
803 | + | |
804 | # This program is free software; you can redistribute it and/or modify | |
805 | # it under the terms of the GNU General Public License as published by | |
806 | # the Free Software Foundation; either version 3 of the License, or | |
807 | @@ -40,7 +41,7 @@ set complex [fortran_complex4] | |
808 | # matches the string TYPE. | |
809 | proc check_pointer_type { var_name type } { | |
810 | gdb_test "ptype ${var_name}" \ | |
811 | - "type = PTR TO -> \\( ${type} \\)" | |
812 | + "type = PTR TO -> \\( ${type}\\)" | |
813 | } | |
140f8057 | 814 | |
e28f2cc1 AM |
815 | gdb_breakpoint [gdb_get_line_number "Before pointer assignment"] |
816 | @@ -85,7 +86,8 @@ gdb_test "ptype twop" \ | |
817 | [multi_line "type = PTR TO -> \\( Type two" \ | |
818 | " $int, allocatable :: ivla1\\(:\\)" \ | |
819 | " $int, allocatable :: ivla2\\(:,:\\)" \ | |
820 | - "End Type two \\)"] | |
821 | + "End Type two\\)"] | |
822 | + | |
140f8057 | 823 | |
e28f2cc1 AM |
824 | gdb_breakpoint [gdb_get_line_number "After value assignment"] |
825 | gdb_continue_to_breakpoint "After value assignment" | |
826 | @@ -97,11 +99,11 @@ gdb_test "ptype intv" "type = $int" | |
827 | gdb_test "ptype inta" "type = $int \\(10,2\\)" | |
828 | gdb_test "ptype realv" "type = $real" | |
140f8057 | 829 | |
e28f2cc1 AM |
830 | -gdb_test "ptype logp" "type = PTR TO -> \\( $logical \\)" |
831 | -gdb_test "ptype comp" "type = PTR TO -> \\( $complex \\)" | |
832 | -gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1 \\)" | |
833 | -gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3 \\)" | |
834 | -gdb_test "ptype intp" "type = PTR TO -> \\( $int \\)" | |
835 | +gdb_test "ptype logp" "type = PTR TO -> \\( $logical\\)" | |
836 | +gdb_test "ptype comp" "type = PTR TO -> \\( $complex\\)" | |
837 | +gdb_test "ptype charp" "type = PTR TO -> \\( character\\*1\\)" | |
838 | +gdb_test "ptype charap" "type = PTR TO -> \\( character\\*3\\)" | |
839 | +gdb_test "ptype intp" "type = PTR TO -> \\( $int\\)" | |
840 | set test "ptype intap" | |
841 | gdb_test_multiple $test $test { | |
842 | -re "type = $int \\(10,2\\)\r\n$gdb_prompt $" { | |
843 | @@ -111,4 +113,4 @@ gdb_test_multiple $test $test { | |
844 | pass $test | |
845 | } | |
846 | } | |
847 | -gdb_test "ptype realp" "type = PTR TO -> \\( $real \\)" | |
848 | +gdb_test "ptype realp" "type = PTR TO -> \\( $real\\)" | |
4b0e5c1b AM |
849 | diff --git a/gdb/testsuite/gdb.fortran/vla-strings.exp b/gdb/testsuite/gdb.fortran/vla-strings.exp |
850 | new file mode 100644 | |
4b0e5c1b AM |
851 | --- /dev/null |
852 | +++ b/gdb/testsuite/gdb.fortran/vla-strings.exp | |
140f8057 JR |
853 | @@ -0,0 +1,103 @@ |
854 | +# Copyright 2016 Free Software Foundation, Inc. | |
855 | + | |
856 | +# This program is free software; you can redistribute it and/or modify | |
857 | +# it under the terms of the GNU General Public License as published by | |
858 | +# the Free Software Foundation; either version 3 of the License, or | |
859 | +# (at your option) any later version. | |
860 | +# | |
861 | +# This program is distributed in the hope that it will be useful, | |
862 | +# but WITHOUT ANY WARRANTY; without even the implied warranty of | |
863 | +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
864 | +# GNU General Public License for more details. | |
865 | +# | |
866 | +# You should have received a copy of the GNU General Public License | |
867 | +# along with this program. If not, see <http://www.gnu.org/licenses/>. | |
868 | + | |
869 | +standard_testfile ".f90" | |
870 | + | |
871 | +if { [prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ | |
872 | + {debug f90 quiet}] } { | |
873 | + return -1 | |
874 | +} | |
875 | + | |
876 | +# check that all fortran standard datatypes will be | |
877 | +# handled correctly when using as VLA's | |
878 | + | |
879 | +if ![runto_main] { | |
880 | + untested "could not run to main" | |
881 | + return -1 | |
882 | +} | |
883 | + | |
884 | +gdb_breakpoint [gdb_get_line_number "var_char-allocated-1"] | |
885 | +gdb_continue_to_breakpoint "var_char-allocated-1" | |
886 | +set test "whatis var_char first time" | |
887 | +gdb_test_multiple "whatis var_char" $test { | |
e28f2cc1 | 888 | + -re "type = PTR TO -> \\( character\\*10\\)\r\n$gdb_prompt $" { |
140f8057 JR |
889 | + pass $test |
890 | + } | |
891 | + -re "type = character\\*10\r\n$gdb_prompt $" { | |
892 | + pass $test | |
893 | + } | |
894 | +} | |
895 | +set test "ptype var_char first time" | |
896 | +gdb_test_multiple "ptype var_char" $test { | |
e28f2cc1 | 897 | + -re "type = PTR TO -> \\( character\\*10\\)\r\n$gdb_prompt $" { |
140f8057 JR |
898 | + pass $test |
899 | + } | |
900 | + -re "type = character\\*10\r\n$gdb_prompt $" { | |
901 | + pass $test | |
902 | + } | |
903 | +} | |
904 | + | |
905 | + | |
906 | +gdb_test "next" "\\d+.*var_char = 'foo'.*" \ | |
907 | + "next to allocation status of var_char" | |
908 | +gdb_test "print l" " = \\.TRUE\\." "print allocation status first time" | |
909 | + | |
910 | + | |
911 | +gdb_breakpoint [gdb_get_line_number "var_char-filled-1"] | |
912 | +gdb_continue_to_breakpoint "var_char-filled-1" | |
913 | +set test "print var_char, var_char-filled-1" | |
914 | +gdb_test_multiple "print var_char" $test { | |
e28f2cc1 | 915 | + -re "= \\(PTR TO -> \\( character\\*3\\)\\) $hex\r\n$gdb_prompt $" { |
140f8057 JR |
916 | + gdb_test "print *var_char" "= 'foo'" "print *var_char, var_char-filled-1" |
917 | + pass $test | |
918 | + } | |
919 | + -re "= 'foo'\r\n$gdb_prompt $" { | |
920 | + pass $test | |
921 | + } | |
922 | +} | |
923 | +set test "ptype var_char, var_char-filled-1" | |
924 | +gdb_test_multiple "ptype var_char" $test { | |
e28f2cc1 | 925 | + -re "type = PTR TO -> \\( character\\*3\\)\r\n$gdb_prompt $" { |
140f8057 JR |
926 | + pass $test |
927 | + } | |
928 | + -re "type = character\\*3\r\n$gdb_prompt $" { | |
929 | + pass $test | |
930 | + } | |
931 | +} | |
932 | +gdb_test "print var_char(1)" " = 102 'f'" "print var_char(1)" | |
933 | +gdb_test "print var_char(3)" " = 111 'o'" "print var_char(3)" | |
934 | + | |
935 | + | |
936 | +gdb_breakpoint [gdb_get_line_number "var_char-filled-2"] | |
937 | +gdb_continue_to_breakpoint "var_char-filled-2" | |
938 | +set test "print var_char, var_char-filled-2" | |
939 | +gdb_test_multiple "print var_char" $test { | |
e28f2cc1 | 940 | + -re "= \\(PTR TO -> \\( character\\*6\\)\\) $hex\r\n$gdb_prompt $" { |
140f8057 JR |
941 | + gdb_test "print *var_char" "= 'foobar'" "print *var_char, var_char-filled-2" |
942 | + pass $test | |
943 | + } | |
944 | + -re "= 'foobar'\r\n$gdb_prompt $" { | |
945 | + pass $test | |
946 | + } | |
947 | +} | |
948 | +set test "ptype var_char, var_char-filled-2" | |
949 | +gdb_test_multiple "ptype var_char" $test { | |
e28f2cc1 | 950 | + -re "type = PTR TO -> \\( character\\*6\\)\r\n$gdb_prompt $" { |
140f8057 JR |
951 | + pass $test |
952 | + } | |
953 | + -re "type = character\\*6\r\n$gdb_prompt $" { | |
954 | + pass $test | |
955 | + } | |
956 | +} | |
4b0e5c1b AM |
957 | diff --git a/gdb/testsuite/gdb.fortran/vla-strings.f90 b/gdb/testsuite/gdb.fortran/vla-strings.f90 |
958 | new file mode 100644 | |
4b0e5c1b AM |
959 | --- /dev/null |
960 | +++ b/gdb/testsuite/gdb.fortran/vla-strings.f90 | |
140f8057 JR |
961 | @@ -0,0 +1,39 @@ |
962 | +! Copyright 2016 Free Software Foundation, Inc. | |
963 | +! | |
964 | +! This program is free software; you can redistribute it and/or modify | |
965 | +! it under the terms of the GNU General Public License as published by | |
966 | +! the Free Software Foundation; either version 3 of the License, or | |
967 | +! (at your option) any later version. | |
968 | +! | |
969 | +! This program is distributed in the hope that it will be useful, | |
970 | +! but WITHOUT ANY WARRANTY; without even the implied warranty of | |
971 | +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
972 | +! GNU General Public License for more details. | |
973 | +! | |
974 | +! You should have received a copy of the GNU General Public License | |
975 | +! along with this program. If not, see <http://www.gnu.org/licenses/>. | |
976 | + | |
977 | +program vla_strings | |
978 | + character(len=:), target, allocatable :: var_char | |
979 | + character(len=:), pointer :: var_char_p | |
980 | + logical :: l | |
981 | + | |
982 | + allocate(character(len=10) :: var_char) | |
983 | + l = allocated(var_char) ! var_char-allocated-1 | |
984 | + var_char = 'foo' | |
985 | + deallocate(var_char) ! var_char-filled-1 | |
986 | + l = allocated(var_char) ! var_char-deallocated | |
987 | + allocate(character(len=42) :: var_char) | |
988 | + l = allocated(var_char) | |
989 | + var_char = 'foobar' | |
990 | + var_char = '' ! var_char-filled-2 | |
991 | + var_char = 'bar' ! var_char-empty | |
992 | + deallocate(var_char) | |
993 | + allocate(character(len=21) :: var_char) | |
994 | + l = allocated(var_char) ! var_char-allocated-3 | |
995 | + var_char = 'johndoe' | |
996 | + var_char_p => var_char | |
997 | + l = associated(var_char_p) ! var_char_p-associated | |
998 | + var_char_p => null() | |
999 | + l = associated(var_char_p) ! var_char_p-not-associated | |
1000 | +end program vla_strings | |
4b0e5c1b | 1001 | diff --git a/gdb/testsuite/gdb.fortran/vla-value.exp b/gdb/testsuite/gdb.fortran/vla-value.exp |
4b0e5c1b AM |
1002 | --- a/gdb/testsuite/gdb.fortran/vla-value.exp |
1003 | +++ b/gdb/testsuite/gdb.fortran/vla-value.exp | |
1004 | @@ -35,7 +35,7 @@ gdb_breakpoint [gdb_get_line_number "vla1-init"] | |
140f8057 JR |
1005 | gdb_continue_to_breakpoint "vla1-init" |
1006 | gdb_test "print vla1" " = <not allocated>" "print non-allocated vla1" | |
1007 | gdb_test "print &vla1" \ | |
e28f2cc1 AM |
1008 | - " = \\\(PTR TO -> \\\( $real, allocatable \\\(:,:,:\\\) \\\)\\\) $hex" \ |
1009 | + " = \\\(PTR TO -> \\\( $real, allocatable \\\(:,:,:\\\)\\\)\\\) $hex" \ | |
140f8057 JR |
1010 | "print non-allocated &vla1" |
1011 | gdb_test "print vla1(1,1,1)" "no such vector element \\\(vector not allocated\\\)" \ | |
1012 | "print member in non-allocated vla1 (1)" | |
e28f2cc1 AM |
1013 | @@ -56,7 +56,7 @@ with_timeout_factor 15 { |
1014 | "step over value assignment of vla1" | |
1015 | } | |
1016 | gdb_test "print &vla1" \ | |
1017 | - " = \\\(PTR TO -> \\\( $real, allocatable \\\(10,10,10\\\) \\\)\\\) $hex" \ | |
1018 | + " = \\\(PTR TO -> \\\( $real, allocatable \\\(10,10,10\\\)\\\)\\\) $hex" \ | |
1019 | "print allocated &vla1" | |
1020 | gdb_test "print vla1(3, 6, 9)" " = 1311" "print allocated vla1(3,6,9)" | |
1021 | gdb_test "print vla1(1, 3, 8)" " = 1311" "print allocated vla1(1,3,8)" | |
4b0e5c1b | 1022 | @@ -76,7 +76,7 @@ gdb_test "print vla1(9, 9, 9)" " = 999" \ |
140f8057 JR |
1023 | # Try to access values in undefined pointer to VLA (dangling) |
1024 | gdb_test "print pvla" " = <not associated>" "print undefined pvla" | |
1025 | gdb_test "print &pvla" \ | |
e28f2cc1 | 1026 | - " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\) \\\)\\\) $hex" \ |
140f8057 JR |
1027 | + " = \\\(PTR TO -> \\\( $real \\\(:,:,:\\\)\\\)\\\) $hex" \ |
1028 | "print non-associated &pvla" | |
1029 | gdb_test "print pvla(1, 3, 8)" "no such vector element \\\(vector not associated\\\)" \ | |
1030 | "print undefined pvla(1,3,8)" | |
e28f2cc1 AM |
1031 | @@ -85,7 +85,7 @@ gdb_test "print pvla(1, 3, 8)" "no such vector element \\\(vector not associated |
1032 | gdb_breakpoint [gdb_get_line_number "pvla-associated"] | |
1033 | gdb_continue_to_breakpoint "pvla-associated" | |
1034 | gdb_test "print &pvla" \ | |
1035 | - " = \\\(PTR TO -> \\\( $real \\\(10,10,10\\\) \\\)\\\) $hex" \ | |
1036 | + " = \\\(PTR TO -> \\\( $real \\\(10,10,10\\\)\\\)\\\) $hex" \ | |
1037 | "print associated &pvla" | |
1038 | gdb_test "print pvla(3, 6, 9)" " = 42" "print associated pvla(3,6,9)" | |
1039 | gdb_test "print pvla(1, 3, 8)" " = 1001" "print associated pvla(1,3,8)" | |
4b0e5c1b | 1040 | diff --git a/gdb/typeprint.c b/gdb/typeprint.c |
4b0e5c1b AM |
1041 | --- a/gdb/typeprint.c |
1042 | +++ b/gdb/typeprint.c | |
e28f2cc1 | 1043 | @@ -574,6 +574,25 @@ whatis_exp (const char *exp, int show) |
140f8057 JR |
1044 | printf_filtered (" */\n"); |
1045 | } | |
1046 | ||
1047 | + /* Resolve any dynamic target type, as we might print | |
1048 | + additional information about the target. | |
1049 | + For example, in Fortran and C we are printing the dimension of the | |
1050 | + dynamic array the pointer is pointing to. */ | |
1051 | + if (TYPE_CODE (type) == TYPE_CODE_PTR | |
1052 | + && is_dynamic_type (type) == 1) | |
1053 | + { | |
1054 | + CORE_ADDR addr; | |
1055 | + if (NULL != TYPE_DATA_LOCATION (TYPE_TARGET_TYPE(type))) | |
1056 | + addr = value_address (val); | |
1057 | + else | |
1058 | + addr = value_as_address (val); | |
1059 | + | |
1060 | + if (addr != 0 | |
1061 | + && type_not_associated (type) == 0) | |
1062 | + TYPE_TARGET_TYPE (type) = resolve_dynamic_type (TYPE_TARGET_TYPE (type), | |
1063 | + NULL, addr); | |
1064 | + } | |
1065 | + | |
1066 | LA_PRINT_TYPE (type, "", gdb_stdout, show, 0, &flags); | |
1067 | printf_filtered ("\n"); | |
ed003b1c | 1068 | } |
4b0e5c1b | 1069 | diff --git a/gdb/valops.c b/gdb/valops.c |
4b0e5c1b AM |
1070 | --- a/gdb/valops.c |
1071 | +++ b/gdb/valops.c | |
77d10998 | 1072 | @@ -1553,6 +1553,19 @@ value_ind (struct value *arg1) |
140f8057 JR |
1073 | if (TYPE_CODE (base_type) == TYPE_CODE_PTR) |
1074 | { | |
1075 | struct type *enc_type; | |
1076 | + CORE_ADDR addr; | |
1077 | + | |
1078 | + if (type_not_associated (base_type)) | |
1079 | + error (_("Attempt to take contents of a not associated pointer.")); | |
1080 | + | |
1081 | + if (NULL != TYPE_DATA_LOCATION (TYPE_TARGET_TYPE (base_type))) | |
1082 | + addr = value_address (arg1); | |
1083 | + else | |
1084 | + addr = value_as_address (arg1); | |
1085 | + | |
1086 | + if (addr != 0) | |
1087 | + TYPE_TARGET_TYPE (base_type) = | |
1088 | + resolve_dynamic_type (TYPE_TARGET_TYPE (base_type), NULL, addr); | |
1089 | ||
1090 | /* We may be pointing to something embedded in a larger object. | |
1091 | Get the real type of the enclosing object. */ | |
77d10998 | 1092 | @@ -1568,8 +1581,7 @@ value_ind (struct value *arg1) |
140f8057 JR |
1093 | else |
1094 | /* Retrieve the enclosing object pointed to. */ | |
1095 | arg2 = value_at_lazy (enc_type, | |
1096 | - (value_as_address (arg1) | |
1097 | - - value_pointed_to_offset (arg1))); | |
1098 | + (addr - value_pointed_to_offset (arg1))); | |
1099 | ||
1100 | enc_type = value_type (arg2); | |
1101 | return readjust_indirect_value_type (arg2, enc_type, base_type, arg1); | |
4b0e5c1b | 1102 | diff --git a/gdb/valprint.c b/gdb/valprint.c |
4b0e5c1b AM |
1103 | --- a/gdb/valprint.c |
1104 | +++ b/gdb/valprint.c | |
e28f2cc1 | 1105 | @@ -1149,12 +1149,6 @@ value_check_printable (struct value *val, struct ui_file *stream, |
140f8057 JR |
1106 | return 0; |
1107 | } | |
1108 | ||
1109 | - if (type_not_associated (value_type (val))) | |
1110 | - { | |
1111 | - val_print_not_associated (stream); | |
1112 | - return 0; | |
1113 | - } | |
1114 | - | |
1115 | if (type_not_allocated (value_type (val))) | |
1116 | { | |
1117 | val_print_not_allocated (stream); |