1 /* Support for printing Fortran values for GDB, the GNU debugger.
2 Copyright 1993, 1994, 1995 Free Software Foundation, Inc.
3 Contributed by Motorola. Adapted from the C definitions by Farooq Butt
4 (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
23 #include "gdb_string.h"
26 #include "expression.h"
37 static int there_is_a_visible_common_named PARAMS ((char *));
40 extern void _initialize_f_valprint PARAMS ((void));
41 static void info_common_command PARAMS ((char *, int));
42 static void list_all_visible_commons PARAMS ((char *));
43 static void f77_print_array PARAMS ((struct type *, char *, CORE_ADDR,
44 GDB_FILE *, int, int, int,
45 enum val_prettyprint));
46 static void f77_print_array_1 PARAMS ((int, int, struct type *, char *,
47 CORE_ADDR, GDB_FILE *, int, int, int,
48 enum val_prettyprint));
49 static void f77_create_arrayprint_offset_tbl PARAMS ((struct type *,
51 static void f77_get_dynamic_length_of_aggregate PARAMS ((struct type *));
53 int f77_array_offset_tbl[MAX_FORTRAN_DIMS+1][2];
55 /* Array which holds offsets to be applied to get a row's elements
56 for a given array. Array also holds the size of each subarray. */
58 /* The following macro gives us the size of the nth dimension, Where
61 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
63 /* The following gives us the offset for row n where n is 1-based. */
65 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
68 f77_get_dynamic_lowerbound (type, lower_bound)
72 CORE_ADDR current_frame_addr;
73 CORE_ADDR ptr_to_lower_bound;
75 switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
77 case BOUND_BY_VALUE_ON_STACK:
78 current_frame_addr = selected_frame->frame;
79 if (current_frame_addr > 0)
82 read_memory_integer (current_frame_addr +
83 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
88 *lower_bound = DEFAULT_LOWER_BOUND;
89 return BOUND_FETCH_ERROR;
94 *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type);
97 case BOUND_CANNOT_BE_DETERMINED:
98 error ("Lower bound may not be '*' in F77");
101 case BOUND_BY_REF_ON_STACK:
102 current_frame_addr = selected_frame->frame;
103 if (current_frame_addr > 0)
106 read_memory_integer (current_frame_addr +
107 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
109 *lower_bound = read_memory_integer (ptr_to_lower_bound, 4);
113 *lower_bound = DEFAULT_LOWER_BOUND;
114 return BOUND_FETCH_ERROR;
118 case BOUND_BY_REF_IN_REG:
119 case BOUND_BY_VALUE_IN_REG:
121 error ("??? unhandled dynamic array bound type ???");
124 return BOUND_FETCH_OK;
128 f77_get_dynamic_upperbound (type, upper_bound)
132 CORE_ADDR current_frame_addr = 0;
133 CORE_ADDR ptr_to_upper_bound;
135 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
137 case BOUND_BY_VALUE_ON_STACK:
138 current_frame_addr = selected_frame->frame;
139 if (current_frame_addr > 0)
142 read_memory_integer (current_frame_addr +
143 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
148 *upper_bound = DEFAULT_UPPER_BOUND;
149 return BOUND_FETCH_ERROR;
154 *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
157 case BOUND_CANNOT_BE_DETERMINED:
158 /* we have an assumed size array on our hands. Assume that
159 upper_bound == lower_bound so that we show at least
160 1 element.If the user wants to see more elements, let
161 him manually ask for 'em and we'll subscript the
162 array and show him */
163 f77_get_dynamic_lowerbound (type, upper_bound);
166 case BOUND_BY_REF_ON_STACK:
167 current_frame_addr = selected_frame->frame;
168 if (current_frame_addr > 0)
171 read_memory_integer (current_frame_addr +
172 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
174 *upper_bound = read_memory_integer(ptr_to_upper_bound, 4);
178 *upper_bound = DEFAULT_UPPER_BOUND;
179 return BOUND_FETCH_ERROR;
183 case BOUND_BY_REF_IN_REG:
184 case BOUND_BY_VALUE_IN_REG:
186 error ("??? unhandled dynamic array bound type ???");
189 return BOUND_FETCH_OK;
192 /* Obtain F77 adjustable array dimensions */
195 f77_get_dynamic_length_of_aggregate (type)
198 int upper_bound = -1;
202 /* Recursively go all the way down into a possibly multi-dimensional
203 F77 array and get the bounds. For simple arrays, this is pretty
204 easy but when the bounds are dynamic, we must be very careful
205 to add up all the lengths correctly. Not doing this right
206 will lead to horrendous-looking arrays in parameter lists.
208 This function also works for strings which behave very
209 similarly to arrays. */
211 if (TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
212 || TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
213 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
215 /* Recursion ends here, start setting up lengths. */
216 retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
217 if (retcode == BOUND_FETCH_ERROR)
218 error ("Cannot obtain valid array lower bound");
220 retcode = f77_get_dynamic_upperbound (type, &upper_bound);
221 if (retcode == BOUND_FETCH_ERROR)
222 error ("Cannot obtain valid array upper bound");
224 /* Patch in a valid length value. */
227 (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
230 /* Function that sets up the array offset,size table for the array
234 f77_create_arrayprint_offset_tbl (type, stream)
238 struct type *tmp_type;
241 int upper, lower, retcode;
245 while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
247 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
248 fprintf_filtered (stream, "<assumed size array> ");
250 retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
251 if (retcode == BOUND_FETCH_ERROR)
252 error ("Cannot obtain dynamic upper bound");
254 retcode = f77_get_dynamic_lowerbound(tmp_type,&lower);
255 if (retcode == BOUND_FETCH_ERROR)
256 error("Cannot obtain dynamic lower bound");
258 F77_DIM_SIZE (ndimen) = upper - lower + 1;
260 tmp_type = TYPE_TARGET_TYPE (tmp_type);
264 /* Now we multiply eltlen by all the offsets, so that later we
265 can print out array elements correctly. Up till now we
266 know an offset to apply to get the item but we also
267 have to know how much to add to get to the next item */
270 eltlen = TYPE_LENGTH (tmp_type);
271 F77_DIM_OFFSET (ndimen) = eltlen;
274 eltlen *= F77_DIM_SIZE (ndimen + 1);
275 F77_DIM_OFFSET (ndimen) = eltlen;
279 /* Actual function which prints out F77 arrays, Valaddr == address in
280 the superior. Address == the address in the inferior. */
283 f77_print_array_1 (nss, ndimensions, type, valaddr, address,
284 stream, format, deref_ref, recurse, pretty)
294 enum val_prettyprint pretty;
298 if (nss != ndimensions)
300 for (i = 0; i< F77_DIM_SIZE(nss); i++)
302 fprintf_filtered (stream, "( ");
303 f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
304 valaddr + i * F77_DIM_OFFSET (nss),
305 address + i * F77_DIM_OFFSET (nss),
306 stream, format, deref_ref, recurse, pretty);
307 fprintf_filtered (stream, ") ");
312 for (i = 0; (i < F77_DIM_SIZE (nss) && i < print_max); i++)
314 val_print (TYPE_TARGET_TYPE (type),
315 valaddr + i * F77_DIM_OFFSET (ndimensions),
317 address + i * F77_DIM_OFFSET (ndimensions),
318 stream, format, deref_ref, recurse, pretty);
320 if (i != (F77_DIM_SIZE (nss) - 1))
321 fprintf_filtered (stream, ", ");
323 if (i == print_max - 1)
324 fprintf_filtered (stream, "...");
329 /* This function gets called to print an F77 array, we set up some
330 stuff and then immediately call f77_print_array_1() */
333 f77_print_array (type, valaddr, address, stream, format, deref_ref, recurse,
342 enum val_prettyprint pretty;
346 ndimensions = calc_f77_array_dims (type);
348 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
349 error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
350 ndimensions, MAX_FORTRAN_DIMS);
352 /* Since F77 arrays are stored column-major, we set up an
353 offset table to get at the various row's elements. The
354 offset table contains entries for both offset and subarray size. */
356 f77_create_arrayprint_offset_tbl (type, stream);
358 f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
359 deref_ref, recurse, pretty);
363 /* Print data of type TYPE located at VALADDR (within GDB), which came from
364 the inferior at address ADDRESS, onto stdio stream STREAM according to
365 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
368 If the data are a string pointer, returns the number of string characters
371 If DEREF_REF is nonzero, then dereference references, otherwise just print
374 The PRETTY parameter controls prettyprinting. */
377 f_val_print (type, valaddr, embedded_offset, address, stream, format, deref_ref, recurse,
387 enum val_prettyprint pretty;
389 register unsigned int i = 0; /* Number of characters printed */
390 struct type *elttype;
394 CHECK_TYPEDEF (type);
395 switch (TYPE_CODE (type))
397 case TYPE_CODE_STRING:
398 f77_get_dynamic_length_of_aggregate (type);
399 LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0);
402 case TYPE_CODE_ARRAY:
403 fprintf_filtered (stream, "(");
404 f77_print_array (type, valaddr, address, stream, format,
405 deref_ref, recurse, pretty);
406 fprintf_filtered (stream, ")");
409 /* Array of unspecified length: treat like pointer to first elt. */
410 valaddr = (char *) &address;
414 if (format && format != 's')
416 print_scalar_formatted (valaddr, type, format, 0, stream);
421 addr = unpack_pointer (type, valaddr);
422 elttype = check_typedef (TYPE_TARGET_TYPE (type));
424 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
426 /* Try to print what function it points to. */
427 print_address_demangle (addr, stream, demangle);
428 /* Return value is irrelevant except for string pointers. */
432 if (addressprint && format != 's')
433 fprintf_filtered (stream, "0x%x", addr);
435 /* For a pointer to char or unsigned char, also print the string
436 pointed to, unless pointer is null. */
437 if (TYPE_LENGTH (elttype) == 1
438 && TYPE_CODE (elttype) == TYPE_CODE_INT
439 && (format == 0 || format == 's')
441 i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream);
443 /* Return number of characters printed, plus one for the
444 terminating null if we have "reached the end". */
445 return (i + (print_max && i != print_max));
452 print_scalar_formatted (valaddr, type, format, 0, stream);
455 /* FIXME, we should consider, at least for ANSI C language, eliminating
456 the distinction made between FUNCs and POINTERs to FUNCs. */
457 fprintf_filtered (stream, "{");
458 type_print (type, "", stream, -1);
459 fprintf_filtered (stream, "} ");
460 /* Try to print what function it points to, and its address. */
461 print_address_demangle (address, stream, demangle);
465 format = format ? format : output_format;
467 print_scalar_formatted (valaddr, type, format, 0, stream);
470 val_print_type_code_int (type, valaddr, stream);
471 /* C and C++ has no single byte int type, char is used instead.
472 Since we don't know whether the value is really intended to
473 be used as an integer or a character, print the character
474 equivalent as well. */
475 if (TYPE_LENGTH (type) == 1)
477 fputs_filtered (" ", stream);
478 LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
486 print_scalar_formatted (valaddr, type, format, 0, stream);
488 print_floating (valaddr, type, stream);
492 fprintf_filtered (stream, "VOID");
495 case TYPE_CODE_ERROR:
496 fprintf_filtered (stream, "<error type>");
499 case TYPE_CODE_RANGE:
500 /* FIXME, we should not ever have to print one of these yet. */
501 fprintf_filtered (stream, "<range type>");
505 format = format ? format : output_format;
507 print_scalar_formatted (valaddr, type, format, 0, stream);
511 switch (TYPE_LENGTH(type))
514 val = unpack_long (builtin_type_f_logical_s1, valaddr);
518 val = unpack_long (builtin_type_f_logical_s2, valaddr);
522 val = unpack_long (builtin_type_f_logical, valaddr);
526 error ("Logicals of length %d bytes not supported",
532 fprintf_filtered (stream, ".FALSE.");
535 fprintf_filtered (stream, ".TRUE.");
537 /* Not a legitimate logical type, print as an integer. */
539 /* Bash the type code temporarily. */
540 TYPE_CODE (type) = TYPE_CODE_INT;
541 f_val_print (type, valaddr, 0, address, stream, format,
542 deref_ref, recurse, pretty);
543 /* Restore the type code so later uses work as intended. */
544 TYPE_CODE (type) = TYPE_CODE_BOOL;
549 case TYPE_CODE_COMPLEX:
550 switch (TYPE_LENGTH (type))
552 case 8: type = builtin_type_f_real; break;
553 case 16: type = builtin_type_f_real_s8; break;
554 case 32: type = builtin_type_f_real_s16; break;
556 error ("Cannot print out complex*%d variables", TYPE_LENGTH(type));
558 fputs_filtered ("(", stream);
559 print_floating (valaddr, type, stream);
560 fputs_filtered (",", stream);
561 print_floating (valaddr, type, stream);
562 fputs_filtered (")", stream);
565 case TYPE_CODE_UNDEF:
566 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
567 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
568 and no complete type for struct foo in that file. */
569 fprintf_filtered (stream, "<incomplete type>");
573 error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type));
580 list_all_visible_commons (funname)
583 SAVED_F77_COMMON_PTR tmp;
585 tmp = head_common_list;
587 printf_filtered ("All COMMON blocks visible at this level:\n\n");
591 if (STREQ(tmp->owning_function,funname))
592 printf_filtered ("%s\n", tmp->name);
598 /* This function is used to print out the values in a given COMMON
599 block. It will always use the most local common block of the
603 info_common_command (comname, from_tty)
607 SAVED_F77_COMMON_PTR the_common;
608 COMMON_ENTRY_PTR entry;
609 struct frame_info *fi;
610 register char *funname = 0;
613 /* We have been told to display the contents of F77 COMMON
614 block supposedly visible in this function. Let us
615 first make sure that it is visible and if so, let
616 us display its contents */
621 error ("No frame selected");
623 /* The following is generally ripped off from stack.c's routine
624 print_frame_info() */
626 func = find_pc_function (fi->pc);
629 /* In certain pathological cases, the symtabs give the wrong
630 function (when we are in the first function in a file which
631 is compiled without debugging symbols, the previous function
632 is compiled with debugging symbols, and the "foo.o" symbol
633 that is supposed to tell us where the file with debugging symbols
634 ends has been truncated by ar because it is longer than 15
637 So look in the minimal symbol tables as well, and if it comes
638 up with a larger address for the function use that instead.
639 I don't think this can ever cause any problems; there shouldn't
640 be any minimal symbols in the middle of a function.
641 FIXME: (Not necessarily true. What about text labels) */
643 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
646 && (SYMBOL_VALUE_ADDRESS (msymbol)
647 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
648 funname = SYMBOL_NAME (msymbol);
650 funname = SYMBOL_NAME (func);
654 register struct minimal_symbol *msymbol =
655 lookup_minimal_symbol_by_pc (fi->pc);
658 funname = SYMBOL_NAME (msymbol);
661 /* If comname is NULL, we assume the user wishes to see the
662 which COMMON blocks are visible here and then return */
666 list_all_visible_commons (funname);
670 the_common = find_common_for_function (comname,funname);
674 if (STREQ(comname,BLANK_COMMON_NAME_LOCAL))
675 printf_filtered ("Contents of blank COMMON block:\n");
677 printf_filtered ("Contents of F77 COMMON block '%s':\n",comname);
679 printf_filtered ("\n");
680 entry = the_common->entries;
682 while (entry != NULL)
684 printf_filtered ("%s = ",SYMBOL_NAME(entry->symbol));
685 print_variable_value (entry->symbol, fi, gdb_stdout);
686 printf_filtered ("\n");
691 printf_filtered ("Cannot locate the common block %s in function '%s'\n",
695 /* This function is used to determine whether there is a
696 F77 common block visible at the current scope called 'comname'. */
700 there_is_a_visible_common_named (comname)
703 SAVED_F77_COMMON_PTR the_common;
704 struct frame_info *fi;
705 register char *funname = 0;
709 error ("Cannot deal with NULL common name!");
714 error ("No frame selected");
716 /* The following is generally ripped off from stack.c's routine
717 print_frame_info() */
719 func = find_pc_function (fi->pc);
722 /* In certain pathological cases, the symtabs give the wrong
723 function (when we are in the first function in a file which
724 is compiled without debugging symbols, the previous function
725 is compiled with debugging symbols, and the "foo.o" symbol
726 that is supposed to tell us where the file with debugging symbols
727 ends has been truncated by ar because it is longer than 15
730 So look in the minimal symbol tables as well, and if it comes
731 up with a larger address for the function use that instead.
732 I don't think this can ever cause any problems; there shouldn't
733 be any minimal symbols in the middle of a function.
734 FIXME: (Not necessarily true. What about text labels) */
736 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
739 && (SYMBOL_VALUE_ADDRESS (msymbol)
740 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
741 funname = SYMBOL_NAME (msymbol);
743 funname = SYMBOL_NAME (func);
747 register struct minimal_symbol *msymbol =
748 lookup_minimal_symbol_by_pc (fi->pc);
751 funname = SYMBOL_NAME (msymbol);
754 the_common = find_common_for_function (comname, funname);
756 return (the_common ? 1 : 0);
761 _initialize_f_valprint ()
763 add_info ("common", info_common_command,
764 "Print out the values contained in a Fortran COMMON block.");
766 add_com("lc", class_info, info_common_command,
767 "Print out the values contained in a Fortran COMMON block.");