]>
Commit | Line | Data |
---|---|---|
c906108c | 1 | /* Support for printing Fortran values for GDB, the GNU debugger. |
a2bd3dcd | 2 | |
213516ef | 3 | Copyright (C) 1993-2023 Free Software Foundation, Inc. |
a2bd3dcd | 4 | |
c906108c SS |
5 | Contributed by Motorola. Adapted from the C definitions by Farooq Butt |
6 | (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs. | |
7 | ||
c5aa993b | 8 | This file is part of GDB. |
c906108c | 9 | |
c5aa993b JM |
10 | This program is free software; you can redistribute it and/or modify |
11 | it under the terms of the GNU General Public License as published by | |
a9762ec7 | 12 | the Free Software Foundation; either version 3 of the License, or |
c5aa993b | 13 | (at your option) any later version. |
c906108c | 14 | |
c5aa993b JM |
15 | This program is distributed in the hope that it will be useful, |
16 | but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | GNU General Public License for more details. | |
c906108c | 19 | |
c5aa993b | 20 | You should have received a copy of the GNU General Public License |
a9762ec7 | 21 | along with this program. If not, see <http://www.gnu.org/licenses/>. */ |
c906108c SS |
22 | |
23 | #include "defs.h" | |
476f77a9 | 24 | #include "annotate.h" |
4de283e4 TT |
25 | #include "symtab.h" |
26 | #include "gdbtypes.h" | |
c906108c | 27 | #include "expression.h" |
4de283e4 TT |
28 | #include "value.h" |
29 | #include "valprint.h" | |
30 | #include "language.h" | |
c5aa993b | 31 | #include "f-lang.h" |
c906108c SS |
32 | #include "frame.h" |
33 | #include "gdbcore.h" | |
4de283e4 TT |
34 | #include "command.h" |
35 | #include "block.h" | |
36 | #include "dictionary.h" | |
7f6aba03 | 37 | #include "cli/cli-style.h" |
5bbd8269 | 38 | #include "gdbarch.h" |
a5c641b5 | 39 | #include "f-array-walker.h" |
c906108c | 40 | |
a14ed312 | 41 | static void f77_get_dynamic_length_of_aggregate (struct type *); |
c906108c | 42 | |
2880242d | 43 | LONGEST |
d78df370 | 44 | f77_get_lowerbound (struct type *type) |
c906108c | 45 | { |
9c0fb734 | 46 | if (!type->bounds ()->low.is_constant ()) |
d78df370 | 47 | error (_("Lower bound may not be '*' in F77")); |
c5aa993b | 48 | |
cf88be68 | 49 | return type->bounds ()->low.const_val (); |
c906108c SS |
50 | } |
51 | ||
2880242d | 52 | LONGEST |
d78df370 | 53 | f77_get_upperbound (struct type *type) |
c906108c | 54 | { |
9c0fb734 | 55 | if (!type->bounds ()->high.is_constant ()) |
c906108c | 56 | { |
d78df370 JK |
57 | /* We have an assumed size array on our hands. Assume that |
58 | upper_bound == lower_bound so that we show at least 1 element. | |
59 | If the user wants to see more elements, let him manually ask for 'em | |
60 | and we'll subscript the array and show him. */ | |
61 | ||
62 | return f77_get_lowerbound (type); | |
c906108c | 63 | } |
d78df370 | 64 | |
cf88be68 | 65 | return type->bounds ()->high.const_val (); |
c906108c SS |
66 | } |
67 | ||
0963b4bd | 68 | /* Obtain F77 adjustable array dimensions. */ |
c906108c SS |
69 | |
70 | static void | |
fba45db2 | 71 | f77_get_dynamic_length_of_aggregate (struct type *type) |
c906108c SS |
72 | { |
73 | int upper_bound = -1; | |
c5aa993b | 74 | int lower_bound = 1; |
c5aa993b | 75 | |
c906108c SS |
76 | /* Recursively go all the way down into a possibly multi-dimensional |
77 | F77 array and get the bounds. For simple arrays, this is pretty | |
78 | easy but when the bounds are dynamic, we must be very careful | |
79 | to add up all the lengths correctly. Not doing this right | |
80 | will lead to horrendous-looking arrays in parameter lists. | |
c5aa993b | 81 | |
c906108c | 82 | This function also works for strings which behave very |
c5aa993b JM |
83 | similarly to arrays. */ |
84 | ||
27710edb SM |
85 | if (type->target_type ()->code () == TYPE_CODE_ARRAY |
86 | || type->target_type ()->code () == TYPE_CODE_STRING) | |
87 | f77_get_dynamic_length_of_aggregate (type->target_type ()); | |
c5aa993b JM |
88 | |
89 | /* Recursion ends here, start setting up lengths. */ | |
d78df370 JK |
90 | lower_bound = f77_get_lowerbound (type); |
91 | upper_bound = f77_get_upperbound (type); | |
c5aa993b | 92 | |
0963b4bd | 93 | /* Patch in a valid length value. */ |
b6cdbc9a | 94 | type->set_length ((upper_bound - lower_bound + 1) |
df86565b | 95 | * check_typedef (type->target_type ())->length ()); |
c5aa993b | 96 | } |
c906108c | 97 | |
476f77a9 MR |
98 | /* Per-dimension statistics. */ |
99 | ||
100 | struct dimension_stats | |
101 | { | |
5d4c63a6 MR |
102 | /* The type of the index used to address elements in the dimension. */ |
103 | struct type *index_type; | |
104 | ||
476f77a9 MR |
105 | /* Total number of elements in the dimension, counted as we go. */ |
106 | int nelts; | |
107 | }; | |
108 | ||
a5c641b5 AB |
109 | /* A class used by FORTRAN_PRINT_ARRAY as a specialisation of the array |
110 | walking template. This specialisation prints Fortran arrays. */ | |
7b0090c3 | 111 | |
a5c641b5 | 112 | class fortran_array_printer_impl : public fortran_array_walker_base_impl |
c906108c | 113 | { |
a5c641b5 AB |
114 | public: |
115 | /* Constructor. TYPE is the array type being printed, ADDRESS is the | |
116 | address in target memory for the object of TYPE being printed. VAL is | |
117 | the GDB value (of TYPE) being printed. STREAM is where to print to, | |
118 | RECOURSE is passed through (and prevents infinite recursion), and | |
119 | OPTIONS are the printing control options. */ | |
120 | explicit fortran_array_printer_impl (struct type *type, | |
121 | CORE_ADDR address, | |
122 | struct value *val, | |
123 | struct ui_file *stream, | |
124 | int recurse, | |
125 | const struct value_print_options *options) | |
126 | : m_elts (0), | |
127 | m_val (val), | |
128 | m_stream (stream), | |
129 | m_recurse (recurse), | |
476f77a9 MR |
130 | m_options (options), |
131 | m_dimension (0), | |
132 | m_nrepeats (0), | |
133 | m_stats (0) | |
a5c641b5 AB |
134 | { /* Nothing. */ } |
135 | ||
136 | /* Called while iterating over the array bounds. When SHOULD_CONTINUE is | |
137 | false then we must return false, as we have reached the end of the | |
138 | array bounds for this dimension. However, we also return false if we | |
139 | have printed too many elements (after printing '...'). In all other | |
140 | cases, return true. */ | |
141 | bool continue_walking (bool should_continue) | |
142 | { | |
143 | bool cont = should_continue && (m_elts < m_options->print_max); | |
144 | if (!cont && should_continue) | |
0426ad51 | 145 | gdb_puts ("...", m_stream); |
a5c641b5 AB |
146 | return cont; |
147 | } | |
148 | ||
149 | /* Called when we start iterating over a dimension. If it's not the | |
150 | inner most dimension then print an opening '(' character. */ | |
5d4c63a6 | 151 | void start_dimension (struct type *index_type, LONGEST nelts, bool inner_p) |
a5c641b5 | 152 | { |
476f77a9 MR |
153 | size_t dim_indx = m_dimension++; |
154 | ||
155 | m_elt_type_prev = nullptr; | |
156 | if (m_stats.size () < m_dimension) | |
157 | { | |
158 | m_stats.resize (m_dimension); | |
5d4c63a6 | 159 | m_stats[dim_indx].index_type = index_type; |
476f77a9 MR |
160 | m_stats[dim_indx].nelts = nelts; |
161 | } | |
162 | ||
0426ad51 | 163 | gdb_puts ("(", m_stream); |
a5c641b5 AB |
164 | } |
165 | ||
166 | /* Called when we finish processing a batch of items within a dimension | |
167 | of the array. Depending on whether this is the inner most dimension | |
168 | or not we print different things, but this is all about adding | |
169 | separators between elements, and dimensions of the array. */ | |
170 | void finish_dimension (bool inner_p, bool last_p) | |
171 | { | |
0426ad51 | 172 | gdb_puts (")", m_stream); |
a5c641b5 | 173 | if (!last_p) |
0426ad51 | 174 | gdb_puts (" ", m_stream); |
476f77a9 MR |
175 | |
176 | m_dimension--; | |
177 | } | |
178 | ||
179 | /* Called when processing dimensions of the array other than the | |
180 | innermost one. WALK_1 is the walker to normally call, ELT_TYPE is | |
181 | the type of the element being extracted, and ELT_OFF is the offset | |
5d4c63a6 MR |
182 | of the element from the start of array being walked, INDEX_TYPE |
183 | and INDEX is the type and the value respectively of the element's | |
184 | index in the dimension currently being walked and LAST_P is true | |
185 | only when this is the last element that will be processed in this | |
186 | dimension. */ | |
476f77a9 MR |
187 | void process_dimension (gdb::function_view<void (struct type *, |
188 | int, bool)> walk_1, | |
5d4c63a6 MR |
189 | struct type *elt_type, LONGEST elt_off, |
190 | LONGEST index, bool last_p) | |
476f77a9 MR |
191 | { |
192 | size_t dim_indx = m_dimension - 1; | |
193 | struct type *elt_type_prev = m_elt_type_prev; | |
194 | LONGEST elt_off_prev = m_elt_off_prev; | |
195 | bool repeated = (m_options->repeat_count_threshold < UINT_MAX | |
196 | && elt_type_prev != nullptr | |
197 | && (m_elts + ((m_nrepeats + 1) | |
198 | * m_stats[dim_indx + 1].nelts) | |
199 | <= m_options->print_max) | |
200 | && dimension_contents_eq (m_val, elt_type, | |
201 | elt_off_prev, elt_off)); | |
202 | ||
203 | if (repeated) | |
204 | m_nrepeats++; | |
205 | if (!repeated || last_p) | |
206 | { | |
207 | LONGEST nrepeats = m_nrepeats; | |
208 | ||
209 | m_nrepeats = 0; | |
210 | if (nrepeats >= m_options->repeat_count_threshold) | |
211 | { | |
212 | annotate_elt_rep (nrepeats + 1); | |
6cb06a8c TT |
213 | gdb_printf (m_stream, "%p[<repeats %s times>%p]", |
214 | metadata_style.style ().ptr (), | |
215 | plongest (nrepeats + 1), | |
216 | nullptr); | |
476f77a9 MR |
217 | annotate_elt_rep_end (); |
218 | if (!repeated) | |
0426ad51 | 219 | gdb_puts (" ", m_stream); |
476f77a9 MR |
220 | m_elts += nrepeats * m_stats[dim_indx + 1].nelts; |
221 | } | |
222 | else | |
223 | for (LONGEST i = nrepeats; i > 0; i--) | |
5d4c63a6 MR |
224 | { |
225 | maybe_print_array_index (m_stats[dim_indx].index_type, | |
226 | index - nrepeats + repeated, | |
227 | m_stream, m_options); | |
228 | walk_1 (elt_type_prev, elt_off_prev, repeated && i == 1); | |
229 | } | |
476f77a9 MR |
230 | |
231 | if (!repeated) | |
232 | { | |
233 | /* We need to specially handle the case of hitting `print_max' | |
234 | exactly as recursing would cause lone `(...)' to be printed. | |
235 | And we need to print `...' by hand if the skipped element | |
236 | would be the last one processed, because the subsequent call | |
237 | to `continue_walking' from our caller won't do that. */ | |
238 | if (m_elts < m_options->print_max) | |
239 | { | |
5d4c63a6 MR |
240 | maybe_print_array_index (m_stats[dim_indx].index_type, index, |
241 | m_stream, m_options); | |
476f77a9 MR |
242 | walk_1 (elt_type, elt_off, last_p); |
243 | nrepeats++; | |
244 | } | |
245 | else if (last_p) | |
0426ad51 | 246 | gdb_puts ("...", m_stream); |
476f77a9 MR |
247 | } |
248 | } | |
249 | ||
250 | m_elt_type_prev = elt_type; | |
251 | m_elt_off_prev = elt_off; | |
a5c641b5 AB |
252 | } |
253 | ||
254 | /* Called to process an element of ELT_TYPE at offset ELT_OFF from the | |
5d4c63a6 MR |
255 | start of the parent object, where INDEX is the value of the element's |
256 | index in the dimension currently being walked and LAST_P is true only | |
257 | when this is the last element to be processed in this dimension. */ | |
258 | void process_element (struct type *elt_type, LONGEST elt_off, | |
259 | LONGEST index, bool last_p) | |
a5c641b5 | 260 | { |
5d4c63a6 | 261 | size_t dim_indx = m_dimension - 1; |
476f77a9 MR |
262 | struct type *elt_type_prev = m_elt_type_prev; |
263 | LONGEST elt_off_prev = m_elt_off_prev; | |
a0c07915 AB |
264 | bool repeated = false; |
265 | ||
266 | if (m_options->repeat_count_threshold < UINT_MAX | |
267 | && elt_type_prev != nullptr) | |
268 | { | |
26568747 TV |
269 | /* When printing large arrays this spot is called frequently, so clean |
270 | up temporary values asap to prevent allocating a large amount of | |
271 | them. */ | |
272 | scoped_value_mark free_values; | |
a0c07915 AB |
273 | struct value *e_val = value_from_component (m_val, elt_type, elt_off); |
274 | struct value *e_prev = value_from_component (m_val, elt_type, | |
275 | elt_off_prev); | |
d00664db TT |
276 | repeated = ((e_prev->entirely_available () |
277 | && e_val->entirely_available () | |
02744ba9 | 278 | && e_prev->contents_eq (e_val)) |
d00664db TT |
279 | || (e_prev->entirely_unavailable () |
280 | && e_val->entirely_unavailable ())); | |
a0c07915 | 281 | } |
476f77a9 MR |
282 | |
283 | if (repeated) | |
284 | m_nrepeats++; | |
285 | if (!repeated || last_p || m_elts + 1 == m_options->print_max) | |
286 | { | |
287 | LONGEST nrepeats = m_nrepeats; | |
288 | bool printed = false; | |
289 | ||
290 | if (nrepeats != 0) | |
291 | { | |
292 | m_nrepeats = 0; | |
293 | if (nrepeats >= m_options->repeat_count_threshold) | |
294 | { | |
295 | annotate_elt_rep (nrepeats + 1); | |
6cb06a8c TT |
296 | gdb_printf (m_stream, "%p[<repeats %s times>%p]", |
297 | metadata_style.style ().ptr (), | |
298 | plongest (nrepeats + 1), | |
299 | nullptr); | |
476f77a9 MR |
300 | annotate_elt_rep_end (); |
301 | } | |
302 | else | |
303 | { | |
304 | /* Extract the element value from the parent value. */ | |
305 | struct value *e_val | |
306 | = value_from_component (m_val, elt_type, elt_off_prev); | |
307 | ||
308 | for (LONGEST i = nrepeats; i > 0; i--) | |
309 | { | |
5d4c63a6 MR |
310 | maybe_print_array_index (m_stats[dim_indx].index_type, |
311 | index - i + 1, | |
312 | m_stream, m_options); | |
476f77a9 MR |
313 | common_val_print (e_val, m_stream, m_recurse, m_options, |
314 | current_language); | |
315 | if (i > 1) | |
0426ad51 | 316 | gdb_puts (", ", m_stream); |
476f77a9 MR |
317 | } |
318 | } | |
319 | printed = true; | |
320 | } | |
321 | ||
322 | if (!repeated) | |
323 | { | |
324 | /* Extract the element value from the parent value. */ | |
325 | struct value *e_val | |
326 | = value_from_component (m_val, elt_type, elt_off); | |
327 | ||
328 | if (printed) | |
0426ad51 | 329 | gdb_puts (", ", m_stream); |
5d4c63a6 MR |
330 | maybe_print_array_index (m_stats[dim_indx].index_type, index, |
331 | m_stream, m_options); | |
476f77a9 MR |
332 | common_val_print (e_val, m_stream, m_recurse, m_options, |
333 | current_language); | |
334 | } | |
335 | if (!last_p) | |
0426ad51 | 336 | gdb_puts (", ", m_stream); |
476f77a9 MR |
337 | } |
338 | ||
339 | m_elt_type_prev = elt_type; | |
340 | m_elt_off_prev = elt_off; | |
a5c641b5 AB |
341 | ++m_elts; |
342 | } | |
343 | ||
344 | private: | |
476f77a9 MR |
345 | /* Called to compare two VAL elements of ELT_TYPE at offsets OFFSET1 |
346 | and OFFSET2 each. Handle subarrays recursively, because they may | |
347 | have been sliced and we do not want to compare any memory contents | |
348 | present between the slices requested. */ | |
349 | bool | |
a0c07915 | 350 | dimension_contents_eq (struct value *val, struct type *type, |
476f77a9 MR |
351 | LONGEST offset1, LONGEST offset2) |
352 | { | |
353 | if (type->code () == TYPE_CODE_ARRAY | |
27710edb | 354 | && type->target_type ()->code () != TYPE_CODE_CHAR) |
476f77a9 MR |
355 | { |
356 | /* Extract the range, and get lower and upper bounds. */ | |
357 | struct type *range_type = check_typedef (type)->index_type (); | |
358 | LONGEST lowerbound, upperbound; | |
359 | if (!get_discrete_bounds (range_type, &lowerbound, &upperbound)) | |
360 | error ("failed to get range bounds"); | |
361 | ||
362 | /* CALC is used to calculate the offsets for each element. */ | |
363 | fortran_array_offset_calculator calc (type); | |
364 | ||
27710edb | 365 | struct type *subarray_type = check_typedef (type->target_type ()); |
476f77a9 MR |
366 | for (LONGEST i = lowerbound; i < upperbound + 1; i++) |
367 | { | |
368 | /* Use the index and the stride to work out a new offset. */ | |
369 | LONGEST index_offset = calc.index_offset (i); | |
370 | ||
371 | if (!dimension_contents_eq (val, subarray_type, | |
372 | offset1 + index_offset, | |
373 | offset2 + index_offset)) | |
374 | return false; | |
375 | } | |
376 | return true; | |
377 | } | |
378 | else | |
a0c07915 AB |
379 | { |
380 | struct value *e_val1 = value_from_component (val, type, offset1); | |
381 | struct value *e_val2 = value_from_component (val, type, offset2); | |
382 | ||
d00664db TT |
383 | return ((e_val1->entirely_available () |
384 | && e_val2->entirely_available () | |
02744ba9 | 385 | && e_val1->contents_eq (e_val2)) |
d00664db TT |
386 | || (e_val1->entirely_unavailable () |
387 | && e_val2->entirely_unavailable ())); | |
a0c07915 | 388 | } |
476f77a9 MR |
389 | } |
390 | ||
a5c641b5 AB |
391 | /* The number of elements printed so far. */ |
392 | int m_elts; | |
393 | ||
394 | /* The value from which we are printing elements. */ | |
395 | struct value *m_val; | |
396 | ||
397 | /* The stream we should print too. */ | |
398 | struct ui_file *m_stream; | |
399 | ||
400 | /* The recursion counter, passed through when we print each element. */ | |
401 | int m_recurse; | |
402 | ||
403 | /* The print control options. Gives us the maximum number of elements to | |
404 | print, and is passed through to each element that we print. */ | |
405 | const struct value_print_options *m_options = nullptr; | |
476f77a9 MR |
406 | |
407 | /* The number of the current dimension being handled. */ | |
408 | LONGEST m_dimension; | |
409 | ||
410 | /* The number of element repetitions in the current series. */ | |
411 | LONGEST m_nrepeats; | |
412 | ||
413 | /* The type and offset from M_VAL of the element handled in the previous | |
414 | iteration over the current dimension. */ | |
415 | struct type *m_elt_type_prev; | |
416 | LONGEST m_elt_off_prev; | |
417 | ||
418 | /* Per-dimension stats. */ | |
419 | std::vector<struct dimension_stats> m_stats; | |
a5c641b5 | 420 | }; |
c906108c | 421 | |
a5c641b5 | 422 | /* This function gets called to print a Fortran array. */ |
c906108c | 423 | |
c5aa993b | 424 | static void |
a5c641b5 AB |
425 | fortran_print_array (struct type *type, CORE_ADDR address, |
426 | struct ui_file *stream, int recurse, | |
427 | const struct value *val, | |
428 | const struct value_print_options *options) | |
c906108c | 429 | { |
a5c641b5 AB |
430 | fortran_array_walker<fortran_array_printer_impl> p |
431 | (type, address, (struct value *) val, stream, recurse, options); | |
432 | p.walk (); | |
c5aa993b | 433 | } |
c906108c | 434 | \f |
c5aa993b | 435 | |
e88acd96 TT |
436 | /* Decorations for Fortran. */ |
437 | ||
438 | static const struct generic_val_print_decorations f_decorations = | |
439 | { | |
440 | "(", | |
441 | ",", | |
442 | ")", | |
443 | ".TRUE.", | |
444 | ".FALSE.", | |
bbe75b9d | 445 | "void", |
00272ec4 TT |
446 | "{", |
447 | "}" | |
e88acd96 TT |
448 | }; |
449 | ||
24051bbe TT |
450 | /* See f-lang.h. */ |
451 | ||
452 | void | |
1a0ea399 AB |
453 | f_language::value_print_inner (struct value *val, struct ui_file *stream, |
454 | int recurse, | |
455 | const struct value_print_options *options) const | |
24051bbe | 456 | { |
d0c97917 | 457 | struct type *type = check_typedef (val->type ()); |
8ee511af | 458 | struct gdbarch *gdbarch = type->arch (); |
6a95a1f5 TT |
459 | int printed_field = 0; /* Number of fields printed. */ |
460 | struct type *elttype; | |
461 | CORE_ADDR addr; | |
462 | int index; | |
efaf1ae0 | 463 | const gdb_byte *valaddr = val->contents_for_printing ().data (); |
9feb2d07 | 464 | const CORE_ADDR address = val->address (); |
6a95a1f5 | 465 | |
78134374 | 466 | switch (type->code ()) |
6a95a1f5 TT |
467 | { |
468 | case TYPE_CODE_STRING: | |
469 | f77_get_dynamic_length_of_aggregate (type); | |
5cc0917c | 470 | printstr (stream, builtin_type (gdbarch)->builtin_char, valaddr, |
df86565b | 471 | type->length (), NULL, 0, options); |
6a95a1f5 TT |
472 | break; |
473 | ||
474 | case TYPE_CODE_ARRAY: | |
27710edb | 475 | if (type->target_type ()->code () != TYPE_CODE_CHAR) |
a5c641b5 | 476 | fortran_print_array (type, address, stream, recurse, val, options); |
6a95a1f5 TT |
477 | else |
478 | { | |
27710edb | 479 | struct type *ch_type = type->target_type (); |
6a95a1f5 TT |
480 | |
481 | f77_get_dynamic_length_of_aggregate (type); | |
5cc0917c | 482 | printstr (stream, ch_type, valaddr, |
df86565b | 483 | type->length () / ch_type->length (), NULL, 0, |
5cc0917c | 484 | options); |
6a95a1f5 TT |
485 | } |
486 | break; | |
487 | ||
488 | case TYPE_CODE_PTR: | |
489 | if (options->format && options->format != 's') | |
490 | { | |
491 | value_print_scalar_formatted (val, options, 0, stream); | |
492 | break; | |
493 | } | |
494 | else | |
495 | { | |
496 | int want_space = 0; | |
497 | ||
498 | addr = unpack_pointer (type, valaddr); | |
27710edb | 499 | elttype = check_typedef (type->target_type ()); |
6a95a1f5 | 500 | |
78134374 | 501 | if (elttype->code () == TYPE_CODE_FUNC) |
6a95a1f5 TT |
502 | { |
503 | /* Try to print what function it points to. */ | |
504 | print_function_pointer_address (options, gdbarch, addr, stream); | |
505 | return; | |
506 | } | |
507 | ||
508 | if (options->symbol_print) | |
509 | want_space = print_address_demangle (options, gdbarch, addr, | |
510 | stream, demangle); | |
511 | else if (options->addressprint && options->format != 's') | |
512 | { | |
0426ad51 | 513 | gdb_puts (paddress (gdbarch, addr), stream); |
6a95a1f5 TT |
514 | want_space = 1; |
515 | } | |
516 | ||
517 | /* For a pointer to char or unsigned char, also print the string | |
518 | pointed to, unless pointer is null. */ | |
df86565b | 519 | if (elttype->length () == 1 |
78134374 | 520 | && elttype->code () == TYPE_CODE_INT |
6a95a1f5 TT |
521 | && (options->format == 0 || options->format == 's') |
522 | && addr != 0) | |
523 | { | |
524 | if (want_space) | |
0426ad51 | 525 | gdb_puts (" ", stream); |
27710edb | 526 | val_print_string (type->target_type (), NULL, addr, -1, |
6a95a1f5 TT |
527 | stream, options); |
528 | } | |
529 | return; | |
530 | } | |
531 | break; | |
532 | ||
6a95a1f5 TT |
533 | case TYPE_CODE_STRUCT: |
534 | case TYPE_CODE_UNION: | |
e9512253 | 535 | case TYPE_CODE_NAMELIST: |
6a95a1f5 | 536 | /* Starting from the Fortran 90 standard, Fortran supports derived |
dda83cd7 | 537 | types. */ |
6cb06a8c | 538 | gdb_printf (stream, "( "); |
1f704f76 | 539 | for (index = 0; index < type->num_fields (); index++) |
dda83cd7 | 540 | { |
e9512253 BK |
541 | struct type *field_type |
542 | = check_typedef (type->field (index).type ()); | |
6a95a1f5 | 543 | |
78134374 | 544 | if (field_type->code () != TYPE_CODE_FUNC) |
6a95a1f5 | 545 | { |
e9512253 BK |
546 | const char *field_name = type->field (index).name (); |
547 | struct value *field; | |
548 | ||
549 | if (type->code () == TYPE_CODE_NAMELIST) | |
550 | { | |
551 | /* While printing namelist items, fetch the appropriate | |
552 | value field before printing its value. */ | |
553 | struct block_symbol sym | |
554 | = lookup_symbol (field_name, get_selected_block (nullptr), | |
555 | VAR_DOMAIN, nullptr); | |
556 | if (sym.symbol == nullptr) | |
557 | error (_("failed to find symbol for name list component %s"), | |
558 | field_name); | |
559 | field = value_of_variable (sym.symbol, sym.block); | |
560 | } | |
561 | else | |
562 | field = value_field (val, index); | |
6a95a1f5 TT |
563 | |
564 | if (printed_field > 0) | |
0426ad51 | 565 | gdb_puts (", ", stream); |
6a95a1f5 | 566 | |
6a95a1f5 TT |
567 | if (field_name != NULL) |
568 | { | |
569 | fputs_styled (field_name, variable_name_style.style (), | |
570 | stream); | |
0426ad51 | 571 | gdb_puts (" = ", stream); |
6a95a1f5 TT |
572 | } |
573 | ||
574 | common_val_print (field, stream, recurse + 1, | |
575 | options, current_language); | |
576 | ||
577 | ++printed_field; | |
578 | } | |
579 | } | |
6cb06a8c | 580 | gdb_printf (stream, " )"); |
6a95a1f5 TT |
581 | break; |
582 | ||
583 | case TYPE_CODE_BOOL: | |
584 | if (options->format || options->output_format) | |
585 | { | |
586 | struct value_print_options opts = *options; | |
587 | opts.format = (options->format ? options->format | |
588 | : options->output_format); | |
589 | value_print_scalar_formatted (val, &opts, 0, stream); | |
590 | } | |
591 | else | |
592 | { | |
593 | LONGEST longval = value_as_long (val); | |
594 | /* The Fortran standard doesn't specify how logical types are | |
595 | represented. Different compilers use different non zero | |
596 | values to represent logical true. */ | |
597 | if (longval == 0) | |
0426ad51 | 598 | gdb_puts (f_decorations.false_name, stream); |
6a95a1f5 | 599 | else |
0426ad51 | 600 | gdb_puts (f_decorations.true_name, stream); |
6a95a1f5 TT |
601 | } |
602 | break; | |
603 | ||
12d8f940 | 604 | case TYPE_CODE_INT: |
6a95a1f5 TT |
605 | case TYPE_CODE_REF: |
606 | case TYPE_CODE_FUNC: | |
607 | case TYPE_CODE_FLAGS: | |
608 | case TYPE_CODE_FLT: | |
609 | case TYPE_CODE_VOID: | |
610 | case TYPE_CODE_ERROR: | |
611 | case TYPE_CODE_RANGE: | |
612 | case TYPE_CODE_UNDEF: | |
613 | case TYPE_CODE_COMPLEX: | |
614 | case TYPE_CODE_CHAR: | |
615 | default: | |
616 | generic_value_print (val, stream, recurse, options, &f_decorations); | |
617 | break; | |
618 | } | |
24051bbe TT |
619 | } |
620 | ||
c906108c | 621 | static void |
3977b71f | 622 | info_common_command_for_block (const struct block *block, const char *comname, |
4357ac6c | 623 | int *any_printed) |
c906108c | 624 | { |
4357ac6c TT |
625 | struct value_print_options opts; |
626 | ||
627 | get_user_print_options (&opts); | |
628 | ||
548a89df | 629 | for (struct symbol *sym : block_iterator_range (block)) |
6c9c307c | 630 | if (sym->domain () == COMMON_BLOCK_DOMAIN) |
4357ac6c | 631 | { |
4aeddc50 | 632 | const struct common_block *common = sym->value_common_block (); |
4357ac6c TT |
633 | size_t index; |
634 | ||
66d7f48f | 635 | gdb_assert (sym->aclass () == LOC_COMMON_BLOCK); |
4357ac6c | 636 | |
987012b8 | 637 | if (comname && (!sym->linkage_name () |
dda83cd7 | 638 | || strcmp (comname, sym->linkage_name ()) != 0)) |
4357ac6c TT |
639 | continue; |
640 | ||
641 | if (*any_printed) | |
a11ac3b3 | 642 | gdb_putc ('\n'); |
4357ac6c TT |
643 | else |
644 | *any_printed = 1; | |
987012b8 | 645 | if (sym->print_name ()) |
6cb06a8c TT |
646 | gdb_printf (_("Contents of F77 COMMON block '%s':\n"), |
647 | sym->print_name ()); | |
4357ac6c | 648 | else |
6cb06a8c | 649 | gdb_printf (_("Contents of blank COMMON block:\n")); |
4357ac6c TT |
650 | |
651 | for (index = 0; index < common->n_entries; index++) | |
652 | { | |
653 | struct value *val = NULL; | |
4357ac6c | 654 | |
6cb06a8c TT |
655 | gdb_printf ("%s = ", |
656 | common->contents[index]->print_name ()); | |
4357ac6c | 657 | |
a70b8144 | 658 | try |
4357ac6c TT |
659 | { |
660 | val = value_of_variable (common->contents[index], block); | |
661 | value_print (val, gdb_stdout, &opts); | |
662 | } | |
663 | ||
230d2906 | 664 | catch (const gdb_exception_error &except) |
492d29ea | 665 | { |
7f6aba03 TT |
666 | fprintf_styled (gdb_stdout, metadata_style.style (), |
667 | "<error reading variable: %s>", | |
668 | except.what ()); | |
492d29ea | 669 | } |
492d29ea | 670 | |
a11ac3b3 | 671 | gdb_putc ('\n'); |
4357ac6c TT |
672 | } |
673 | } | |
c906108c SS |
674 | } |
675 | ||
676 | /* This function is used to print out the values in a given COMMON | |
0963b4bd MS |
677 | block. It will always use the most local common block of the |
678 | given name. */ | |
c906108c | 679 | |
c5aa993b | 680 | static void |
1d12d88f | 681 | info_common_command (const char *comname, int from_tty) |
c906108c | 682 | { |
bd2b40ac | 683 | frame_info_ptr fi; |
3977b71f | 684 | const struct block *block; |
4357ac6c | 685 | int values_printed = 0; |
c5aa993b | 686 | |
c906108c SS |
687 | /* We have been told to display the contents of F77 COMMON |
688 | block supposedly visible in this function. Let us | |
689 | first make sure that it is visible and if so, let | |
0963b4bd | 690 | us display its contents. */ |
c5aa993b | 691 | |
206415a3 | 692 | fi = get_selected_frame (_("No frame selected")); |
c5aa993b | 693 | |
c906108c | 694 | /* The following is generally ripped off from stack.c's routine |
0963b4bd | 695 | print_frame_info(). */ |
c5aa993b | 696 | |
4357ac6c TT |
697 | block = get_frame_block (fi, 0); |
698 | if (block == NULL) | |
c906108c | 699 | { |
6cb06a8c | 700 | gdb_printf (_("No symbol table info available.\n")); |
4357ac6c | 701 | return; |
c906108c | 702 | } |
c5aa993b | 703 | |
4357ac6c | 704 | while (block) |
c906108c | 705 | { |
4357ac6c TT |
706 | info_common_command_for_block (block, comname, &values_printed); |
707 | /* After handling the function's top-level block, stop. Don't | |
dda83cd7 | 708 | continue to its superblock, the block of per-file symbols. */ |
6c00f721 | 709 | if (block->function ()) |
4357ac6c | 710 | break; |
f135fe72 | 711 | block = block->superblock (); |
c906108c | 712 | } |
c5aa993b | 713 | |
4357ac6c | 714 | if (!values_printed) |
c906108c | 715 | { |
4357ac6c | 716 | if (comname) |
6cb06a8c | 717 | gdb_printf (_("No common block '%s'.\n"), comname); |
c5aa993b | 718 | else |
6cb06a8c | 719 | gdb_printf (_("No common blocks.\n")); |
c906108c | 720 | } |
c906108c SS |
721 | } |
722 | ||
6c265988 | 723 | void _initialize_f_valprint (); |
c906108c | 724 | void |
6c265988 | 725 | _initialize_f_valprint () |
c906108c SS |
726 | { |
727 | add_info ("common", info_common_command, | |
1bedd215 | 728 | _("Print out the values contained in a Fortran COMMON block.")); |
c906108c | 729 | } |