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.
7 This file is part of GDB.
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.
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.
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. */
25 #include "gdb_string.h"
28 #include "expression.h"
39 static int there_is_a_visible_common_named (char *);
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,
52 static void f77_create_arrayprint_offset_tbl (struct type *,
54 static void f77_get_dynamic_length_of_aggregate (struct type *);
56 int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
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. */
61 /* The following macro gives us the size of the nth dimension, Where
64 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
66 /* The following gives us the offset for row n where n is 1-based. */
68 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
71 f77_get_dynamic_lowerbound (struct type *type, int *lower_bound)
73 CORE_ADDR current_frame_addr;
74 CORE_ADDR ptr_to_lower_bound;
76 switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
78 case BOUND_BY_VALUE_ON_STACK:
79 current_frame_addr = get_frame_base (deprecated_selected_frame);
80 if (current_frame_addr > 0)
83 read_memory_integer (current_frame_addr +
84 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
89 *lower_bound = DEFAULT_LOWER_BOUND;
90 return BOUND_FETCH_ERROR;
95 *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type);
98 case BOUND_CANNOT_BE_DETERMINED:
99 error ("Lower bound may not be '*' in F77");
102 case BOUND_BY_REF_ON_STACK:
103 current_frame_addr = get_frame_base (deprecated_selected_frame);
104 if (current_frame_addr > 0)
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);
114 *lower_bound = DEFAULT_LOWER_BOUND;
115 return BOUND_FETCH_ERROR;
119 case BOUND_BY_REF_IN_REG:
120 case BOUND_BY_VALUE_IN_REG:
122 error ("??? unhandled dynamic array bound type ???");
125 return BOUND_FETCH_OK;
129 f77_get_dynamic_upperbound (struct type *type, int *upper_bound)
131 CORE_ADDR current_frame_addr = 0;
132 CORE_ADDR ptr_to_upper_bound;
134 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
136 case BOUND_BY_VALUE_ON_STACK:
137 current_frame_addr = get_frame_base (deprecated_selected_frame);
138 if (current_frame_addr > 0)
141 read_memory_integer (current_frame_addr +
142 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
147 *upper_bound = DEFAULT_UPPER_BOUND;
148 return BOUND_FETCH_ERROR;
153 *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
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);
165 case BOUND_BY_REF_ON_STACK:
166 current_frame_addr = get_frame_base (deprecated_selected_frame);
167 if (current_frame_addr > 0)
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);
177 *upper_bound = DEFAULT_UPPER_BOUND;
178 return BOUND_FETCH_ERROR;
182 case BOUND_BY_REF_IN_REG:
183 case BOUND_BY_VALUE_IN_REG:
185 error ("??? unhandled dynamic array bound type ???");
188 return BOUND_FETCH_OK;
191 /* Obtain F77 adjustable array dimensions */
194 f77_get_dynamic_length_of_aggregate (struct type *type)
196 int upper_bound = -1;
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.
206 This function also works for strings which behave very
207 similarly to arrays. */
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));
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");
218 retcode = f77_get_dynamic_upperbound (type, &upper_bound);
219 if (retcode == BOUND_FETCH_ERROR)
220 error ("Cannot obtain valid array upper bound");
222 /* Patch in a valid length value. */
225 (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
228 /* Function that sets up the array offset,size table for the array
232 f77_create_arrayprint_offset_tbl (struct type *type, struct ui_file *stream)
234 struct type *tmp_type;
237 int upper, lower, retcode;
241 while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
243 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
244 fprintf_filtered (stream, "<assumed size array> ");
246 retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
247 if (retcode == BOUND_FETCH_ERROR)
248 error ("Cannot obtain dynamic upper bound");
250 retcode = f77_get_dynamic_lowerbound (tmp_type, &lower);
251 if (retcode == BOUND_FETCH_ERROR)
252 error ("Cannot obtain dynamic lower bound");
254 F77_DIM_SIZE (ndimen) = upper - lower + 1;
256 tmp_type = TYPE_TARGET_TYPE (tmp_type);
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 */
266 eltlen = TYPE_LENGTH (tmp_type);
267 F77_DIM_OFFSET (ndimen) = eltlen;
270 eltlen *= F77_DIM_SIZE (ndimen + 1);
271 F77_DIM_OFFSET (ndimen) = eltlen;
277 /* Actual function which prints out F77 arrays, Valaddr == address in
278 the superior. Address == the address in the inferior. */
280 f77_print_array_1 (int nss, int ndimensions, struct type *type, char *valaddr,
281 CORE_ADDR address, struct ui_file *stream, int format,
282 int deref_ref, int recurse, enum val_prettyprint pretty,
287 if (nss != ndimensions)
289 for (i = 0; i < F77_DIM_SIZE (nss) && *elts < print_max; i++)
291 fprintf_filtered (stream, "( ");
292 f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
293 valaddr + i * F77_DIM_OFFSET (nss),
294 address + i * F77_DIM_OFFSET (nss),
295 stream, format, deref_ref, recurse, pretty, elts);
296 fprintf_filtered (stream, ") ");
298 if (*elts >= print_max && i < F77_DIM_SIZE (nss)) {
299 fprintf_filtered (stream, "...");
304 for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); i++ , (*elts)++)
306 val_print (TYPE_TARGET_TYPE (type),
307 valaddr + i * F77_DIM_OFFSET (ndimensions),
309 address + i * F77_DIM_OFFSET (ndimensions),
310 stream, format, deref_ref, recurse, pretty);
312 if (i != (F77_DIM_SIZE (nss) - 1))
313 fprintf_filtered (stream, ", ");
315 if ((( *elts) == print_max - 1) &&(i != (F77_DIM_SIZE (nss) - 1)))
316 fprintf_filtered (stream, "...");
321 /* This function gets called to print an F77 array, we set up some
322 stuff and then immediately call f77_print_array_1() */
325 f77_print_array (struct type *type, char *valaddr, CORE_ADDR address,
326 struct ui_file *stream, int format, int deref_ref, int recurse,
327 enum val_prettyprint pretty)
332 ndimensions = calc_f77_array_dims (type);
334 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
335 error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
336 ndimensions, MAX_FORTRAN_DIMS);
338 /* Since F77 arrays are stored column-major, we set up an
339 offset table to get at the various row's elements. The
340 offset table contains entries for both offset and subarray size. */
342 f77_create_arrayprint_offset_tbl (type, stream);
344 f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
345 deref_ref, recurse, pretty, &elts);
349 /* Print data of type TYPE located at VALADDR (within GDB), which came from
350 the inferior at address ADDRESS, onto stdio stream STREAM according to
351 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
354 If the data are a string pointer, returns the number of string characters
357 If DEREF_REF is nonzero, then dereference references, otherwise just print
360 The PRETTY parameter controls prettyprinting. */
363 f_val_print (struct type *type, char *valaddr, int embedded_offset,
364 CORE_ADDR address, struct ui_file *stream, int format,
365 int deref_ref, int recurse, enum val_prettyprint pretty)
367 register unsigned int i = 0; /* Number of characters printed */
368 struct type *elttype;
372 CHECK_TYPEDEF (type);
373 switch (TYPE_CODE (type))
375 case TYPE_CODE_STRING:
376 f77_get_dynamic_length_of_aggregate (type);
377 LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
380 case TYPE_CODE_ARRAY:
381 fprintf_filtered (stream, "(");
382 f77_print_array (type, valaddr, address, stream, format,
383 deref_ref, recurse, pretty);
384 fprintf_filtered (stream, ")");
387 /* Array of unspecified length: treat like pointer to first elt. */
388 valaddr = (char *) &address;
392 if (format && format != 's')
394 print_scalar_formatted (valaddr, type, format, 0, stream);
399 addr = unpack_pointer (type, valaddr);
400 elttype = check_typedef (TYPE_TARGET_TYPE (type));
402 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
404 /* Try to print what function it points to. */
405 print_address_demangle (addr, stream, demangle);
406 /* Return value is irrelevant except for string pointers. */
410 if (addressprint && format != 's')
411 fprintf_filtered (stream, "0x%s", paddr_nz (addr));
413 /* For a pointer to char or unsigned char, also print the string
414 pointed to, unless pointer is null. */
415 if (TYPE_LENGTH (elttype) == 1
416 && TYPE_CODE (elttype) == TYPE_CODE_INT
417 && (format == 0 || format == 's')
419 i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
421 /* Return number of characters printed, plus one for the
422 terminating null if we have "reached the end". */
423 return (i + (print_max && i != print_max));
430 print_scalar_formatted (valaddr, type, format, 0, stream);
433 /* FIXME, we should consider, at least for ANSI C language, eliminating
434 the distinction made between FUNCs and POINTERs to FUNCs. */
435 fprintf_filtered (stream, "{");
436 type_print (type, "", stream, -1);
437 fprintf_filtered (stream, "} ");
438 /* Try to print what function it points to, and its address. */
439 print_address_demangle (address, stream, demangle);
443 format = format ? format : output_format;
445 print_scalar_formatted (valaddr, type, format, 0, stream);
448 val_print_type_code_int (type, valaddr, stream);
449 /* C and C++ has no single byte int type, char is used instead.
450 Since we don't know whether the value is really intended to
451 be used as an integer or a character, print the character
452 equivalent as well. */
453 if (TYPE_LENGTH (type) == 1)
455 fputs_filtered (" ", stream);
456 LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
464 print_scalar_formatted (valaddr, type, format, 0, stream);
466 print_floating (valaddr, type, stream);
470 fprintf_filtered (stream, "VOID");
473 case TYPE_CODE_ERROR:
474 fprintf_filtered (stream, "<error type>");
477 case TYPE_CODE_RANGE:
478 /* FIXME, we should not ever have to print one of these yet. */
479 fprintf_filtered (stream, "<range type>");
483 format = format ? format : output_format;
485 print_scalar_formatted (valaddr, type, format, 0, stream);
489 switch (TYPE_LENGTH (type))
492 val = unpack_long (builtin_type_f_logical_s1, valaddr);
496 val = unpack_long (builtin_type_f_logical_s2, valaddr);
500 val = unpack_long (builtin_type_f_logical, valaddr);
504 error ("Logicals of length %d bytes not supported",
510 fprintf_filtered (stream, ".FALSE.");
512 fprintf_filtered (stream, ".TRUE.");
514 /* Not a legitimate logical type, print as an integer. */
516 /* Bash the type code temporarily. */
517 TYPE_CODE (type) = TYPE_CODE_INT;
518 f_val_print (type, valaddr, 0, address, stream, format,
519 deref_ref, recurse, pretty);
520 /* Restore the type code so later uses work as intended. */
521 TYPE_CODE (type) = TYPE_CODE_BOOL;
526 case TYPE_CODE_COMPLEX:
527 switch (TYPE_LENGTH (type))
530 type = builtin_type_f_real;
533 type = builtin_type_f_real_s8;
536 type = builtin_type_f_real_s16;
539 error ("Cannot print out complex*%d variables", TYPE_LENGTH (type));
541 fputs_filtered ("(", stream);
542 print_floating (valaddr, type, stream);
543 fputs_filtered (",", stream);
544 print_floating (valaddr + TYPE_LENGTH (type), type, stream);
545 fputs_filtered (")", stream);
548 case TYPE_CODE_UNDEF:
549 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
550 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
551 and no complete type for struct foo in that file. */
552 fprintf_filtered (stream, "<incomplete type>");
556 error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type));
563 list_all_visible_commons (char *funname)
565 SAVED_F77_COMMON_PTR tmp;
567 tmp = head_common_list;
569 printf_filtered ("All COMMON blocks visible at this level:\n\n");
573 if (strcmp (tmp->owning_function, funname) == 0)
574 printf_filtered ("%s\n", tmp->name);
580 /* This function is used to print out the values in a given COMMON
581 block. It will always use the most local common block of the
585 info_common_command (char *comname, int from_tty)
587 SAVED_F77_COMMON_PTR the_common;
588 COMMON_ENTRY_PTR entry;
589 struct frame_info *fi;
590 register char *funname = 0;
593 /* We have been told to display the contents of F77 COMMON
594 block supposedly visible in this function. Let us
595 first make sure that it is visible and if so, let
596 us display its contents */
598 fi = deprecated_selected_frame;
601 error ("No frame selected");
603 /* The following is generally ripped off from stack.c's routine
604 print_frame_info() */
606 func = find_pc_function (get_frame_pc (fi));
609 /* In certain pathological cases, the symtabs give the wrong
610 function (when we are in the first function in a file which
611 is compiled without debugging symbols, the previous function
612 is compiled with debugging symbols, and the "foo.o" symbol
613 that is supposed to tell us where the file with debugging symbols
614 ends has been truncated by ar because it is longer than 15
617 So look in the minimal symbol tables as well, and if it comes
618 up with a larger address for the function use that instead.
619 I don't think this can ever cause any problems; there shouldn't
620 be any minimal symbols in the middle of a function.
621 FIXME: (Not necessarily true. What about text labels) */
623 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
626 && (SYMBOL_VALUE_ADDRESS (msymbol)
627 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
628 funname = DEPRECATED_SYMBOL_NAME (msymbol);
630 funname = DEPRECATED_SYMBOL_NAME (func);
634 register struct minimal_symbol *msymbol =
635 lookup_minimal_symbol_by_pc (get_frame_pc (fi));
638 funname = DEPRECATED_SYMBOL_NAME (msymbol);
641 /* If comname is NULL, we assume the user wishes to see the
642 which COMMON blocks are visible here and then return */
646 list_all_visible_commons (funname);
650 the_common = find_common_for_function (comname, funname);
654 if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
655 printf_filtered ("Contents of blank COMMON block:\n");
657 printf_filtered ("Contents of F77 COMMON block '%s':\n", comname);
659 printf_filtered ("\n");
660 entry = the_common->entries;
662 while (entry != NULL)
664 printf_filtered ("%s = ", DEPRECATED_SYMBOL_NAME (entry->symbol));
665 print_variable_value (entry->symbol, fi, gdb_stdout);
666 printf_filtered ("\n");
671 printf_filtered ("Cannot locate the common block %s in function '%s'\n",
675 /* This function is used to determine whether there is a
676 F77 common block visible at the current scope called 'comname'. */
680 there_is_a_visible_common_named (char *comname)
682 SAVED_F77_COMMON_PTR the_common;
683 struct frame_info *fi;
684 register char *funname = 0;
688 error ("Cannot deal with NULL common name!");
690 fi = deprecated_selected_frame;
693 error ("No frame selected");
695 /* The following is generally ripped off from stack.c's routine
696 print_frame_info() */
698 func = find_pc_function (fi->pc);
701 /* In certain pathological cases, the symtabs give the wrong
702 function (when we are in the first function in a file which
703 is compiled without debugging symbols, the previous function
704 is compiled with debugging symbols, and the "foo.o" symbol
705 that is supposed to tell us where the file with debugging symbols
706 ends has been truncated by ar because it is longer than 15
709 So look in the minimal symbol tables as well, and if it comes
710 up with a larger address for the function use that instead.
711 I don't think this can ever cause any problems; there shouldn't
712 be any minimal symbols in the middle of a function.
713 FIXME: (Not necessarily true. What about text labels) */
715 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
718 && (SYMBOL_VALUE_ADDRESS (msymbol)
719 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
720 funname = DEPRECATED_SYMBOL_NAME (msymbol);
722 funname = DEPRECATED_SYMBOL_NAME (func);
726 register struct minimal_symbol *msymbol =
727 lookup_minimal_symbol_by_pc (fi->pc);
730 funname = DEPRECATED_SYMBOL_NAME (msymbol);
733 the_common = find_common_for_function (comname, funname);
735 return (the_common ? 1 : 0);
740 _initialize_f_valprint (void)
742 add_info ("common", info_common_command,
743 "Print out the values contained in a Fortran COMMON block.");
745 add_com ("lc", class_info, info_common_command,
746 "Print out the values contained in a Fortran COMMON block.");