gdb/
[deliverable/binutils-gdb.git] / gdb / f-valprint.c
CommitLineData
c906108c 1/* Support for printing Fortran values for GDB, the GNU debugger.
a2bd3dcd 2
6aba47ca 3 Copyright (C) 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2003, 2005, 2006,
7b6bb8da 4 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
a2bd3dcd 5
c906108c
SS
6 Contributed by Motorola. Adapted from the C definitions by Farooq Butt
7 (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
8
c5aa993b 9 This file is part of GDB.
c906108c 10
c5aa993b
JM
11 This program is free software; you can redistribute it and/or modify
12 it under the terms of the GNU General Public License as published by
a9762ec7 13 the Free Software Foundation; either version 3 of the License, or
c5aa993b 14 (at your option) any later version.
c906108c 15
c5aa993b
JM
16 This program is distributed in the hope that it will be useful,
17 but WITHOUT ANY WARRANTY; without even the implied warranty of
18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 GNU General Public License for more details.
c906108c 20
c5aa993b 21 You should have received a copy of the GNU General Public License
a9762ec7 22 along with this program. If not, see <http://www.gnu.org/licenses/>. */
c906108c
SS
23
24#include "defs.h"
25#include "gdb_string.h"
26#include "symtab.h"
27#include "gdbtypes.h"
28#include "expression.h"
29#include "value.h"
c906108c
SS
30#include "valprint.h"
31#include "language.h"
c5aa993b 32#include "f-lang.h"
c906108c
SS
33#include "frame.h"
34#include "gdbcore.h"
35#include "command.h"
fe898f56 36#include "block.h"
c906108c
SS
37
38#if 0
a14ed312 39static int there_is_a_visible_common_named (char *);
c906108c
SS
40#endif
41
a14ed312
KB
42extern void _initialize_f_valprint (void);
43static void info_common_command (char *, int);
44static void list_all_visible_commons (char *);
d9fcf2fb
JM
45static void f77_create_arrayprint_offset_tbl (struct type *,
46 struct ui_file *);
a14ed312 47static void f77_get_dynamic_length_of_aggregate (struct type *);
c906108c 48
c5aa993b 49int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
c906108c
SS
50
51/* Array which holds offsets to be applied to get a row's elements
0963b4bd 52 for a given array. Array also holds the size of each subarray. */
c906108c
SS
53
54/* The following macro gives us the size of the nth dimension, Where
0963b4bd 55 n is 1 based. */
c906108c
SS
56
57#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
58
0963b4bd 59/* The following gives us the offset for row n where n is 1-based. */
c906108c
SS
60
61#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
62
c5aa993b 63int
d78df370 64f77_get_lowerbound (struct type *type)
c906108c 65{
d78df370
JK
66 if (TYPE_ARRAY_LOWER_BOUND_IS_UNDEFINED (type))
67 error (_("Lower bound may not be '*' in F77"));
c5aa993b 68
d78df370 69 return TYPE_ARRAY_LOWER_BOUND_VALUE (type);
c906108c
SS
70}
71
c5aa993b 72int
d78df370 73f77_get_upperbound (struct type *type)
c906108c 74{
d78df370 75 if (TYPE_ARRAY_UPPER_BOUND_IS_UNDEFINED (type))
c906108c 76 {
d78df370
JK
77 /* We have an assumed size array on our hands. Assume that
78 upper_bound == lower_bound so that we show at least 1 element.
79 If the user wants to see more elements, let him manually ask for 'em
80 and we'll subscript the array and show him. */
81
82 return f77_get_lowerbound (type);
c906108c 83 }
d78df370
JK
84
85 return TYPE_ARRAY_UPPER_BOUND_VALUE (type);
c906108c
SS
86}
87
0963b4bd 88/* Obtain F77 adjustable array dimensions. */
c906108c
SS
89
90static void
fba45db2 91f77_get_dynamic_length_of_aggregate (struct type *type)
c906108c
SS
92{
93 int upper_bound = -1;
c5aa993b 94 int lower_bound = 1;
c5aa993b 95
c906108c
SS
96 /* Recursively go all the way down into a possibly multi-dimensional
97 F77 array and get the bounds. For simple arrays, this is pretty
98 easy but when the bounds are dynamic, we must be very careful
99 to add up all the lengths correctly. Not doing this right
100 will lead to horrendous-looking arrays in parameter lists.
c5aa993b 101
c906108c 102 This function also works for strings which behave very
c5aa993b
JM
103 similarly to arrays. */
104
105 if (TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
106 || TYPE_CODE (TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
c906108c 107 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
c5aa993b
JM
108
109 /* Recursion ends here, start setting up lengths. */
d78df370
JK
110 lower_bound = f77_get_lowerbound (type);
111 upper_bound = f77_get_upperbound (type);
c5aa993b 112
0963b4bd 113 /* Patch in a valid length value. */
c5aa993b 114
c906108c 115 TYPE_LENGTH (type) =
3e43a32a
MS
116 (upper_bound - lower_bound + 1)
117 * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
c5aa993b 118}
c906108c
SS
119
120/* Function that sets up the array offset,size table for the array
c5aa993b 121 type "type". */
c906108c 122
c5aa993b 123static void
fba45db2 124f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
c906108c
SS
125{
126 struct type *tmp_type;
127 int eltlen;
128 int ndimen = 1;
9216103f 129 int upper, lower;
c5aa993b
JM
130
131 tmp_type = type;
132
133 while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
c906108c 134 {
d78df370
JK
135 upper = f77_get_upperbound (tmp_type);
136 lower = f77_get_lowerbound (tmp_type);
c5aa993b 137
c906108c 138 F77_DIM_SIZE (ndimen) = upper - lower + 1;
c5aa993b 139
c906108c 140 tmp_type = TYPE_TARGET_TYPE (tmp_type);
c5aa993b 141 ndimen++;
c906108c 142 }
c5aa993b 143
c906108c
SS
144 /* Now we multiply eltlen by all the offsets, so that later we
145 can print out array elements correctly. Up till now we
146 know an offset to apply to get the item but we also
0963b4bd 147 have to know how much to add to get to the next item. */
c5aa993b 148
c906108c 149 ndimen--;
c5aa993b 150 eltlen = TYPE_LENGTH (tmp_type);
c906108c
SS
151 F77_DIM_OFFSET (ndimen) = eltlen;
152 while (--ndimen > 0)
153 {
154 eltlen *= F77_DIM_SIZE (ndimen + 1);
155 F77_DIM_OFFSET (ndimen) = eltlen;
156 }
157}
158
b3cacbee
DL
159
160
c906108c
SS
161/* Actual function which prints out F77 arrays, Valaddr == address in
162 the superior. Address == the address in the inferior. */
7b0090c3 163
c5aa993b 164static void
a2bd3dcd 165f77_print_array_1 (int nss, int ndimensions, struct type *type,
490f124f
PA
166 const gdb_byte *valaddr,
167 int embedded_offset, CORE_ADDR address,
79a45b7d 168 struct ui_file *stream, int recurse,
0e03807e 169 const struct value *val,
79a45b7d 170 const struct value_print_options *options,
b3cacbee 171 int *elts)
c906108c
SS
172{
173 int i;
c5aa993b 174
c906108c
SS
175 if (nss != ndimensions)
176 {
3e43a32a
MS
177 for (i = 0;
178 (i < F77_DIM_SIZE (nss) && (*elts) < options->print_max);
179 i++)
c906108c
SS
180 {
181 fprintf_filtered (stream, "( ");
182 f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
490f124f
PA
183 valaddr,
184 embedded_offset + i * F77_DIM_OFFSET (nss),
185 address,
0e03807e 186 stream, recurse, val, options, elts);
c906108c
SS
187 fprintf_filtered (stream, ") ");
188 }
79a45b7d 189 if (*elts >= options->print_max && i < F77_DIM_SIZE (nss))
b3cacbee 190 fprintf_filtered (stream, "...");
c906108c
SS
191 }
192 else
193 {
79a45b7d 194 for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < options->print_max;
7b0090c3 195 i++, (*elts)++)
c906108c
SS
196 {
197 val_print (TYPE_TARGET_TYPE (type),
490f124f
PA
198 valaddr,
199 embedded_offset + i * F77_DIM_OFFSET (ndimensions),
200 address, stream, recurse,
201 val, options, current_language);
c906108c
SS
202
203 if (i != (F77_DIM_SIZE (nss) - 1))
c5aa993b
JM
204 fprintf_filtered (stream, ", ");
205
79a45b7d
TT
206 if ((*elts == options->print_max - 1)
207 && (i != (F77_DIM_SIZE (nss) - 1)))
c906108c
SS
208 fprintf_filtered (stream, "...");
209 }
210 }
211}
212
213/* This function gets called to print an F77 array, we set up some
0963b4bd 214 stuff and then immediately call f77_print_array_1(). */
c906108c 215
c5aa993b 216static void
fc1a4b47 217f77_print_array (struct type *type, const gdb_byte *valaddr,
490f124f 218 int embedded_offset,
a2bd3dcd 219 CORE_ADDR address, struct ui_file *stream,
0e03807e
TT
220 int recurse,
221 const struct value *val,
222 const struct value_print_options *options)
c906108c 223{
c5aa993b 224 int ndimensions;
b3cacbee 225 int elts = 0;
c5aa993b
JM
226
227 ndimensions = calc_f77_array_dims (type);
228
c906108c 229 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
3e43a32a
MS
230 error (_("\
231Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)"),
c906108c 232 ndimensions, MAX_FORTRAN_DIMS);
c5aa993b 233
c906108c 234 /* Since F77 arrays are stored column-major, we set up an
0963b4bd
MS
235 offset table to get at the various row's elements. The
236 offset table contains entries for both offset and subarray size. */
c906108c 237
c5aa993b
JM
238 f77_create_arrayprint_offset_tbl (type, stream);
239
490f124f
PA
240 f77_print_array_1 (1, ndimensions, type, valaddr, embedded_offset,
241 address, stream, recurse, val, options, &elts);
c5aa993b 242}
c906108c 243\f
c5aa993b 244
32b72a42
PA
245/* See val_print for a description of the various parameters of this
246 function; they are identical. The semantics of the return value is
247 also identical to val_print. */
c906108c
SS
248
249int
fc1a4b47 250f_val_print (struct type *type, const gdb_byte *valaddr, int embedded_offset,
79a45b7d 251 CORE_ADDR address, struct ui_file *stream, int recurse,
0e03807e 252 const struct value *original_value,
79a45b7d 253 const struct value_print_options *options)
c906108c 254{
50810684 255 struct gdbarch *gdbarch = get_type_arch (type);
e17a4113 256 enum bfd_endian byte_order = gdbarch_byte_order (gdbarch);
0963b4bd 257 unsigned int i = 0; /* Number of characters printed. */
c906108c
SS
258 struct type *elttype;
259 LONGEST val;
260 CORE_ADDR addr;
2a5e440c 261 int index;
c5aa993b 262
c906108c
SS
263 CHECK_TYPEDEF (type);
264 switch (TYPE_CODE (type))
265 {
c5aa993b 266 case TYPE_CODE_STRING:
c906108c 267 f77_get_dynamic_length_of_aggregate (type);
50810684 268 LA_PRINT_STRING (stream, builtin_type (gdbarch)->builtin_char,
490f124f
PA
269 valaddr + embedded_offset,
270 TYPE_LENGTH (type), NULL, 0, options);
c906108c 271 break;
c5aa993b 272
c906108c 273 case TYPE_CODE_ARRAY:
3b2b8fea
TT
274 if (TYPE_CODE (TYPE_TARGET_TYPE (type)) != TYPE_CODE_CHAR)
275 {
276 fprintf_filtered (stream, "(");
277 f77_print_array (type, valaddr, embedded_offset,
278 address, stream, recurse, original_value, options);
279 fprintf_filtered (stream, ")");
280 }
281 else
282 {
283 struct type *ch_type = TYPE_TARGET_TYPE (type);
284
285 f77_get_dynamic_length_of_aggregate (type);
286 LA_PRINT_STRING (stream, ch_type,
287 valaddr + embedded_offset,
288 TYPE_LENGTH (type) / TYPE_LENGTH (ch_type),
289 NULL, 0, options);
290 }
c906108c 291 break;
7e86466e 292
c906108c 293 case TYPE_CODE_PTR:
79a45b7d 294 if (options->format && options->format != 's')
c906108c 295 {
ab2188aa
PA
296 val_print_scalar_formatted (type, valaddr, embedded_offset,
297 original_value, options, 0, stream);
c906108c
SS
298 break;
299 }
300 else
301 {
490f124f 302 addr = unpack_pointer (type, valaddr + embedded_offset);
c906108c 303 elttype = check_typedef (TYPE_TARGET_TYPE (type));
c5aa993b 304
c906108c
SS
305 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
306 {
307 /* Try to print what function it points to. */
5af949e3 308 print_address_demangle (gdbarch, addr, stream, demangle);
c906108c
SS
309 /* Return value is irrelevant except for string pointers. */
310 return 0;
311 }
c5aa993b 312
79a45b7d 313 if (options->addressprint && options->format != 's')
5af949e3 314 fputs_filtered (paddress (gdbarch, addr), stream);
c5aa993b 315
c906108c
SS
316 /* For a pointer to char or unsigned char, also print the string
317 pointed to, unless pointer is null. */
318 if (TYPE_LENGTH (elttype) == 1
319 && TYPE_CODE (elttype) == TYPE_CODE_INT
79a45b7d 320 && (options->format == 0 || options->format == 's')
c906108c 321 && addr != 0)
09ca9e2e
TT
322 i = val_print_string (TYPE_TARGET_TYPE (type), NULL, addr, -1,
323 stream, options);
c5aa993b 324
7e86466e
RH
325 /* Return number of characters printed, including the terminating
326 '\0' if we reached the end. val_print_string takes care including
327 the terminating '\0' if necessary. */
328 return i;
329 }
330 break;
331
332 case TYPE_CODE_REF:
333 elttype = check_typedef (TYPE_TARGET_TYPE (type));
79a45b7d 334 if (options->addressprint)
7e86466e
RH
335 {
336 CORE_ADDR addr
337 = extract_typed_address (valaddr + embedded_offset, type);
bb9bcb69 338
7e86466e 339 fprintf_filtered (stream, "@");
5af949e3 340 fputs_filtered (paddress (gdbarch, addr), stream);
79a45b7d 341 if (options->deref_ref)
7e86466e
RH
342 fputs_filtered (": ", stream);
343 }
344 /* De-reference the reference. */
79a45b7d 345 if (options->deref_ref)
7e86466e
RH
346 {
347 if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
348 {
a471c594
JK
349 struct value *deref_val;
350
351 deref_val = coerce_ref_if_computed (original_value);
352 if (deref_val != NULL)
353 {
354 /* More complicated computed references are not supported. */
355 gdb_assert (embedded_offset == 0);
356 }
357 else
358 deref_val = value_at (TYPE_TARGET_TYPE (type),
359 unpack_pointer (type,
360 (valaddr
361 + embedded_offset)));
bb9bcb69 362
79a45b7d
TT
363 common_val_print (deref_val, stream, recurse,
364 options, current_language);
7e86466e
RH
365 }
366 else
367 fputs_filtered ("???", stream);
c906108c
SS
368 }
369 break;
c5aa993b 370
c906108c 371 case TYPE_CODE_FUNC:
79a45b7d 372 if (options->format)
c906108c 373 {
ab2188aa
PA
374 val_print_scalar_formatted (type, valaddr, embedded_offset,
375 original_value, options, 0, stream);
c906108c
SS
376 break;
377 }
378 /* FIXME, we should consider, at least for ANSI C language, eliminating
c5aa993b 379 the distinction made between FUNCs and POINTERs to FUNCs. */
c906108c
SS
380 fprintf_filtered (stream, "{");
381 type_print (type, "", stream, -1);
382 fprintf_filtered (stream, "} ");
383 /* Try to print what function it points to, and its address. */
5af949e3 384 print_address_demangle (gdbarch, address, stream, demangle);
c906108c 385 break;
c5aa993b 386
c906108c 387 case TYPE_CODE_INT:
3b2b8fea 388 case TYPE_CODE_CHAR:
79a45b7d
TT
389 if (options->format || options->output_format)
390 {
391 struct value_print_options opts = *options;
bb9bcb69 392
79a45b7d
TT
393 opts.format = (options->format ? options->format
394 : options->output_format);
ab2188aa
PA
395 val_print_scalar_formatted (type, valaddr, embedded_offset,
396 original_value, options, 0, stream);
79a45b7d 397 }
c906108c
SS
398 else
399 {
490f124f 400 val_print_type_code_int (type, valaddr + embedded_offset, stream);
c906108c
SS
401 /* C and C++ has no single byte int type, char is used instead.
402 Since we don't know whether the value is really intended to
403 be used as an integer or a character, print the character
0963b4bd 404 equivalent as well. */
3b2b8fea 405 if (TYPE_LENGTH (type) == 1 || TYPE_CODE (type) == TYPE_CODE_CHAR)
c906108c 406 {
490f124f
PA
407 LONGEST c;
408
c906108c 409 fputs_filtered (" ", stream);
490f124f
PA
410 c = unpack_long (type, valaddr + embedded_offset);
411 LA_PRINT_CHAR ((unsigned char) c, type, stream);
c906108c
SS
412 }
413 }
414 break;
c5aa993b 415
4f2aea11 416 case TYPE_CODE_FLAGS:
79a45b7d 417 if (options->format)
ab2188aa
PA
418 val_print_scalar_formatted (type, valaddr, embedded_offset,
419 original_value, options, 0, stream);
4f2aea11 420 else
490f124f 421 val_print_type_code_flags (type, valaddr + embedded_offset, stream);
4f2aea11
MK
422 break;
423
c906108c 424 case TYPE_CODE_FLT:
79a45b7d 425 if (options->format)
ab2188aa
PA
426 val_print_scalar_formatted (type, valaddr, embedded_offset,
427 original_value, options, 0, stream);
c906108c 428 else
490f124f 429 print_floating (valaddr + embedded_offset, type, stream);
c906108c 430 break;
c5aa993b 431
c906108c
SS
432 case TYPE_CODE_VOID:
433 fprintf_filtered (stream, "VOID");
434 break;
c5aa993b 435
c906108c 436 case TYPE_CODE_ERROR:
b00fdb78 437 fprintf_filtered (stream, "%s", TYPE_ERROR_NAME (type));
c906108c 438 break;
c5aa993b 439
c906108c
SS
440 case TYPE_CODE_RANGE:
441 /* FIXME, we should not ever have to print one of these yet. */
442 fprintf_filtered (stream, "<range type>");
443 break;
c5aa993b 444
c906108c 445 case TYPE_CODE_BOOL:
79a45b7d
TT
446 if (options->format || options->output_format)
447 {
448 struct value_print_options opts = *options;
bb9bcb69 449
79a45b7d
TT
450 opts.format = (options->format ? options->format
451 : options->output_format);
ab2188aa
PA
452 val_print_scalar_formatted (type, valaddr, embedded_offset,
453 original_value, &opts, 0, stream);
79a45b7d 454 }
c906108c
SS
455 else
456 {
490f124f 457 val = extract_unsigned_integer (valaddr + embedded_offset,
e17a4113 458 TYPE_LENGTH (type), byte_order);
c5aa993b 459 if (val == 0)
c906108c 460 fprintf_filtered (stream, ".FALSE.");
c5aa993b
JM
461 else if (val == 1)
462 fprintf_filtered (stream, ".TRUE.");
463 else
464 /* Not a legitimate logical type, print as an integer. */
465 {
466 /* Bash the type code temporarily. */
467 TYPE_CODE (type) = TYPE_CODE_INT;
490f124f
PA
468 val_print (type, valaddr, embedded_offset,
469 address, stream, recurse,
0e03807e 470 original_value, options, current_language);
0963b4bd 471 /* Restore the type code so later uses work as intended. */
c5aa993b
JM
472 TYPE_CODE (type) = TYPE_CODE_BOOL;
473 }
c906108c
SS
474 }
475 break;
c5aa993b 476
c906108c 477 case TYPE_CODE_COMPLEX:
b806fb9a 478 type = TYPE_TARGET_TYPE (type);
c906108c 479 fputs_filtered ("(", stream);
490f124f 480 print_floating (valaddr + embedded_offset, type, stream);
c906108c 481 fputs_filtered (",", stream);
490f124f
PA
482 print_floating (valaddr + embedded_offset + TYPE_LENGTH (type),
483 type, stream);
c906108c
SS
484 fputs_filtered (")", stream);
485 break;
c5aa993b 486
c906108c
SS
487 case TYPE_CODE_UNDEF:
488 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
c5aa993b
JM
489 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
490 and no complete type for struct foo in that file. */
c906108c
SS
491 fprintf_filtered (stream, "<incomplete type>");
492 break;
c5aa993b 493
2a5e440c 494 case TYPE_CODE_STRUCT:
9eec4d1e 495 case TYPE_CODE_UNION:
2a5e440c
WZ
496 /* Starting from the Fortran 90 standard, Fortran supports derived
497 types. */
9eec4d1e 498 fprintf_filtered (stream, "( ");
2a5e440c
WZ
499 for (index = 0; index < TYPE_NFIELDS (type); index++)
500 {
501 int offset = TYPE_FIELD_BITPOS (type, index) / 8;
bb9bcb69 502
490f124f
PA
503 val_print (TYPE_FIELD_TYPE (type, index), valaddr,
504 embedded_offset + offset,
505 address, stream, recurse + 1,
0e03807e 506 original_value, options, current_language);
2a5e440c
WZ
507 if (index != TYPE_NFIELDS (type) - 1)
508 fputs_filtered (", ", stream);
509 }
9eec4d1e 510 fprintf_filtered (stream, " )");
2a5e440c
WZ
511 break;
512
c906108c 513 default:
8a3fe4f8 514 error (_("Invalid F77 type code %d in symbol table."), TYPE_CODE (type));
c906108c
SS
515 }
516 gdb_flush (stream);
517 return 0;
518}
519
520static void
fba45db2 521list_all_visible_commons (char *funname)
c906108c 522{
c5aa993b
JM
523 SAVED_F77_COMMON_PTR tmp;
524
c906108c 525 tmp = head_common_list;
c5aa993b 526
a3f17187 527 printf_filtered (_("All COMMON blocks visible at this level:\n\n"));
c5aa993b 528
c906108c
SS
529 while (tmp != NULL)
530 {
762f08a3 531 if (strcmp (tmp->owning_function, funname) == 0)
c5aa993b
JM
532 printf_filtered ("%s\n", tmp->name);
533
c906108c
SS
534 tmp = tmp->next;
535 }
536}
537
538/* This function is used to print out the values in a given COMMON
0963b4bd
MS
539 block. It will always use the most local common block of the
540 given name. */
c906108c 541
c5aa993b 542static void
fba45db2 543info_common_command (char *comname, int from_tty)
c906108c 544{
c5aa993b
JM
545 SAVED_F77_COMMON_PTR the_common;
546 COMMON_ENTRY_PTR entry;
c906108c 547 struct frame_info *fi;
52f0bd74 548 char *funname = 0;
c906108c 549 struct symbol *func;
c5aa993b 550
c906108c
SS
551 /* We have been told to display the contents of F77 COMMON
552 block supposedly visible in this function. Let us
553 first make sure that it is visible and if so, let
0963b4bd 554 us display its contents. */
c5aa993b 555
206415a3 556 fi = get_selected_frame (_("No frame selected"));
c5aa993b 557
c906108c 558 /* The following is generally ripped off from stack.c's routine
0963b4bd 559 print_frame_info(). */
c5aa993b 560
bdd78e62 561 func = find_pc_function (get_frame_pc (fi));
c906108c
SS
562 if (func)
563 {
564 /* In certain pathological cases, the symtabs give the wrong
c5aa993b
JM
565 function (when we are in the first function in a file which
566 is compiled without debugging symbols, the previous function
567 is compiled with debugging symbols, and the "foo.o" symbol
568 that is supposed to tell us where the file with debugging symbols
569 ends has been truncated by ar because it is longer than 15
570 characters).
571
572 So look in the minimal symbol tables as well, and if it comes
573 up with a larger address for the function use that instead.
574 I don't think this can ever cause any problems; there shouldn't
575 be any minimal symbols in the middle of a function.
0963b4bd 576 FIXME: (Not necessarily true. What about text labels?) */
c5aa993b 577
7c6e0d48
MS
578 struct minimal_symbol *msymbol =
579 lookup_minimal_symbol_by_pc (get_frame_pc (fi));
c5aa993b 580
c906108c 581 if (msymbol != NULL
c5aa993b 582 && (SYMBOL_VALUE_ADDRESS (msymbol)
c906108c 583 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
3567439c 584 funname = SYMBOL_LINKAGE_NAME (msymbol);
c906108c 585 else
3567439c 586 funname = SYMBOL_LINKAGE_NAME (func);
c906108c
SS
587 }
588 else
589 {
aa1ee363 590 struct minimal_symbol *msymbol =
bb9bcb69 591 lookup_minimal_symbol_by_pc (get_frame_pc (fi));
c5aa993b 592
c906108c 593 if (msymbol != NULL)
3567439c 594 funname = SYMBOL_LINKAGE_NAME (msymbol);
7c6e0d48
MS
595 else /* Got no 'funname', code below will fail. */
596 error (_("No function found for frame."));
c906108c 597 }
c5aa993b 598
c906108c 599 /* If comname is NULL, we assume the user wishes to see the
0963b4bd 600 which COMMON blocks are visible here and then return. */
c5aa993b 601
c906108c
SS
602 if (comname == 0)
603 {
604 list_all_visible_commons (funname);
c5aa993b 605 return;
c906108c 606 }
c5aa993b
JM
607
608 the_common = find_common_for_function (comname, funname);
609
c906108c
SS
610 if (the_common)
611 {
762f08a3 612 if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
a3f17187 613 printf_filtered (_("Contents of blank COMMON block:\n"));
c5aa993b 614 else
a3f17187 615 printf_filtered (_("Contents of F77 COMMON block '%s':\n"), comname);
c5aa993b
JM
616
617 printf_filtered ("\n");
618 entry = the_common->entries;
619
c906108c
SS
620 while (entry != NULL)
621 {
aad95b57 622 print_variable_and_value (NULL, entry->symbol, fi, gdb_stdout, 0);
c5aa993b 623 entry = entry->next;
c906108c
SS
624 }
625 }
c5aa993b 626 else
a3f17187 627 printf_filtered (_("Cannot locate the common block %s in function '%s'\n"),
c5aa993b 628 comname, funname);
c906108c
SS
629}
630
631/* This function is used to determine whether there is a
0963b4bd 632 F77 common block visible at the current scope called 'comname'. */
c906108c
SS
633
634#if 0
635static int
fba45db2 636there_is_a_visible_common_named (char *comname)
c906108c 637{
c5aa993b 638 SAVED_F77_COMMON_PTR the_common;
c906108c 639 struct frame_info *fi;
52f0bd74 640 char *funname = 0;
c906108c 641 struct symbol *func;
c5aa993b 642
c906108c 643 if (comname == NULL)
8a3fe4f8 644 error (_("Cannot deal with NULL common name!"));
c5aa993b 645
206415a3 646 fi = get_selected_frame (_("No frame selected"));
c5aa993b 647
c906108c 648 /* The following is generally ripped off from stack.c's routine
0963b4bd 649 print_frame_info(). */
c5aa993b 650
c906108c
SS
651 func = find_pc_function (fi->pc);
652 if (func)
653 {
654 /* In certain pathological cases, the symtabs give the wrong
c5aa993b
JM
655 function (when we are in the first function in a file which
656 is compiled without debugging symbols, the previous function
657 is compiled with debugging symbols, and the "foo.o" symbol
658 that is supposed to tell us where the file with debugging symbols
659 ends has been truncated by ar because it is longer than 15
660 characters).
661
662 So look in the minimal symbol tables as well, and if it comes
663 up with a larger address for the function use that instead.
664 I don't think this can ever cause any problems; there shouldn't
665 be any minimal symbols in the middle of a function.
0963b4bd 666 FIXME: (Not necessarily true. What about text labels?) */
c5aa993b 667
c906108c 668 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
c5aa993b 669
c906108c 670 if (msymbol != NULL
c5aa993b 671 && (SYMBOL_VALUE_ADDRESS (msymbol)
c906108c 672 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
3567439c 673 funname = SYMBOL_LINKAGE_NAME (msymbol);
c906108c 674 else
3567439c 675 funname = SYMBOL_LINKAGE_NAME (func);
c906108c
SS
676 }
677 else
678 {
aa1ee363 679 struct minimal_symbol *msymbol =
bb9bcb69 680 lookup_minimal_symbol_by_pc (fi->pc);
c5aa993b 681
c906108c 682 if (msymbol != NULL)
3567439c 683 funname = SYMBOL_LINKAGE_NAME (msymbol);
c906108c 684 }
c5aa993b
JM
685
686 the_common = find_common_for_function (comname, funname);
687
c906108c
SS
688 return (the_common ? 1 : 0);
689}
690#endif
691
692void
fba45db2 693_initialize_f_valprint (void)
c906108c
SS
694{
695 add_info ("common", info_common_command,
1bedd215 696 _("Print out the values contained in a Fortran COMMON block."));
c906108c 697 if (xdb_commands)
c5aa993b 698 add_com ("lc", class_info, info_common_command,
1bedd215 699 _("Print out the values contained in a Fortran COMMON block."));
c906108c 700}
This page took 1.260497 seconds and 4 git commands to generate.