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