1 /* Support for printing Fortran values for GDB, the GNU debugger.
2 Copyright 1993, 1994 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., 675 Mass Ave, Cambridge, MA 02139, USA. */
26 #include "expression.h"
36 extern struct obstack dont_print_obstack;
38 extern unsigned int print_max; /* No of array elements to print */
40 extern int calc_f77_array_dims PARAMS ((struct type *));
42 int f77_array_offset_tbl[MAX_FORTRAN_DIMS+1][2];
44 /* Array which holds offsets to be applied to get a row's elements
45 for a given array. Array also holds the size of each subarray. */
47 /* The following macro gives us the size of the nth dimension, Where
50 #define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
52 /* The following gives us the offset for row n where n is 1-based. */
54 #define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
57 f77_get_dynamic_lowerbound (type, lower_bound)
61 CORE_ADDR current_frame_addr;
62 CORE_ADDR ptr_to_lower_bound;
64 switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type))
66 case BOUND_BY_VALUE_ON_STACK:
67 current_frame_addr = selected_frame->frame;
68 if (current_frame_addr > 0)
71 read_memory_integer (current_frame_addr +
72 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
77 *lower_bound = DEFAULT_LOWER_BOUND;
78 return BOUND_FETCH_ERROR;
83 *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type);
86 case BOUND_CANNOT_BE_DETERMINED:
87 error ("Lower bound may not be '*' in F77");
90 case BOUND_BY_REF_ON_STACK:
91 current_frame_addr = selected_frame->frame;
92 if (current_frame_addr > 0)
95 read_memory_integer (current_frame_addr +
96 TYPE_ARRAY_LOWER_BOUND_VALUE (type),
98 *lower_bound = read_memory_integer (ptr_to_lower_bound, 4);
102 *lower_bound = DEFAULT_LOWER_BOUND;
103 return BOUND_FETCH_ERROR;
107 case BOUND_BY_REF_IN_REG:
108 case BOUND_BY_VALUE_IN_REG:
110 error ("??? unhandled dynamic array bound type ???");
113 return BOUND_FETCH_OK;
117 f77_get_dynamic_upperbound (type, upper_bound)
121 CORE_ADDR current_frame_addr = 0;
122 CORE_ADDR ptr_to_upper_bound;
124 switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type))
126 case BOUND_BY_VALUE_ON_STACK:
127 current_frame_addr = selected_frame->frame;
128 if (current_frame_addr > 0)
131 read_memory_integer (current_frame_addr +
132 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
137 *upper_bound = DEFAULT_UPPER_BOUND;
138 return BOUND_FETCH_ERROR;
143 *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type);
146 case BOUND_CANNOT_BE_DETERMINED:
147 /* we have an assumed size array on our hands. Assume that
148 upper_bound == lower_bound so that we show at least
149 1 element.If the user wants to see more elements, let
150 him manually ask for 'em and we'll subscript the
151 array and show him */
152 f77_get_dynamic_lowerbound (type, upper_bound);
155 case BOUND_BY_REF_ON_STACK:
156 current_frame_addr = selected_frame->frame;
157 if (current_frame_addr > 0)
160 read_memory_integer (current_frame_addr +
161 TYPE_ARRAY_UPPER_BOUND_VALUE (type),
163 *upper_bound = read_memory_integer(ptr_to_upper_bound, 4);
167 *upper_bound = DEFAULT_UPPER_BOUND;
168 return BOUND_FETCH_ERROR;
172 case BOUND_BY_REF_IN_REG:
173 case BOUND_BY_VALUE_IN_REG:
175 error ("??? unhandled dynamic array bound type ???");
178 return BOUND_FETCH_OK;
181 /* Obtain F77 adjustable array dimensions */
184 f77_get_dynamic_length_of_aggregate (type)
187 int upper_bound = -1;
191 /* Recursively go all the way down into a possibly multi-dimensional
192 F77 array and get the bounds. For simple arrays, this is pretty
193 easy but when the bounds are dynamic, we must be very careful
194 to add up all the lengths correctly. Not doing this right
195 will lead to horrendous-looking arrays in parameter lists.
197 This function also works for strings which behave very
198 similarly to arrays. */
200 if (TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY
201 || TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING)
202 f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type));
204 /* Recursion ends here, start setting up lengths. */
205 retcode = f77_get_dynamic_lowerbound (type, &lower_bound);
206 if (retcode == BOUND_FETCH_ERROR)
207 error ("Cannot obtain valid array lower bound");
209 retcode = f77_get_dynamic_upperbound (type, &upper_bound);
210 if (retcode == BOUND_FETCH_ERROR)
211 error ("Cannot obtain valid array upper bound");
213 /* Patch in a valid length value. */
216 (upper_bound - lower_bound + 1) * TYPE_LENGTH (TYPE_TARGET_TYPE (type));
219 /* Print a FORTRAN COMPLEX value of type TYPE, pointed to in GDB by VALADDR,
220 on STREAM. which_complex indicates precision, which may be regular,
224 f77_print_cmplx (valaddr, type, stream, which_complex)
233 switch (which_complex)
235 case TARGET_COMPLEX_BIT:
236 f1 = (float *) valaddr;
237 f2 = (float *) (valaddr + sizeof(float));
238 fprintf_filtered (stream, "(%.7e,%.7e)", *f1, *f2);
241 case TARGET_DOUBLE_COMPLEX_BIT:
242 d1 = (double *) valaddr;
243 d2 = (double *) (valaddr + sizeof(double));
244 fprintf_filtered (stream, "(%.16e,%.16e)", *d1, *d2);
247 case TARGET_EXT_COMPLEX_BIT:
248 fprintf_filtered (stream, "<complex*32 format unavailable, "
249 "printing raw data>\n");
251 fprintf_filtered (stream, "( [ ");
254 fprintf_filtered (stream, "0x%x ",
255 * ( (unsigned int *) valaddr+i));
257 fprintf_filtered (stream, "],\n [ ");
260 fprintf_filtered (stream, "0x%x ",
261 * ((unsigned int *) valaddr+i));
263 fprintf_filtered (stream, "] )");
268 fprintf_filtered (stream, "<cannot handle complex of this type>");
273 /* Function that sets up the array offset,size table for the array
277 f77_create_arrayprint_offset_tbl (type, stream)
281 struct type *tmp_type;
284 int upper, lower, retcode;
288 while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
290 if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED)
291 fprintf_filtered (stream, "<assumed size array> ");
293 retcode = f77_get_dynamic_upperbound (tmp_type, &upper);
294 if (retcode == BOUND_FETCH_ERROR)
295 error ("Cannot obtain dynamic upper bound");
297 retcode = f77_get_dynamic_lowerbound(tmp_type,&lower);
298 if (retcode == BOUND_FETCH_ERROR)
299 error("Cannot obtain dynamic lower bound");
301 F77_DIM_SIZE (ndimen) = upper - lower + 1;
304 F77_DIM_OFFSET (ndimen) = 1;
306 F77_DIM_OFFSET (ndimen) =
307 F77_DIM_OFFSET (ndimen - 1) * F77_DIM_SIZE(ndimen - 1);
309 tmp_type = TYPE_TARGET_TYPE (tmp_type);
313 eltlen = TYPE_LENGTH (tmp_type);
315 /* Now we multiply eltlen by all the offsets, so that later we
316 can print out array elements correctly. Up till now we
317 know an offset to apply to get the item but we also
318 have to know how much to add to get to the next item */
323 while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
325 F77_DIM_OFFSET (ndimen) *= eltlen;
327 tmp_type = TYPE_TARGET_TYPE (tmp_type);
331 /* Actual function which prints out F77 arrays, Valaddr == address in
332 the superior. Address == the address in the inferior. */
335 f77_print_array_1 (nss, ndimensions, type, valaddr, address,
336 stream, format, deref_ref, recurse, pretty)
346 enum val_prettyprint pretty;
350 if (nss != ndimensions)
352 for (i = 0; i< F77_DIM_SIZE(nss); i++)
354 fprintf_filtered (stream, "( ");
355 f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type),
356 valaddr + i * F77_DIM_OFFSET (nss),
357 address + i * F77_DIM_OFFSET (nss),
358 stream, format, deref_ref, recurse, pretty, i);
359 fprintf_filtered (stream, ") ");
364 for (i = 0; (i < F77_DIM_SIZE (nss) && i < print_max); i++)
366 val_print (TYPE_TARGET_TYPE (type),
367 valaddr + i * F77_DIM_OFFSET (ndimensions),
368 address + i * F77_DIM_OFFSET (ndimensions),
369 stream, format, deref_ref, recurse, pretty);
371 if (i != (F77_DIM_SIZE (nss) - 1))
372 fprintf_filtered (stream, ", ");
374 if (i == print_max - 1)
375 fprintf_filtered (stream, "...");
380 /* This function gets called to print an F77 array, we set up some
381 stuff and then immediately call f77_print_array_1() */
384 f77_print_array (type, valaddr, address, stream, format, deref_ref, recurse,
393 enum val_prettyprint pretty;
397 ndimensions = calc_f77_array_dims (type);
399 if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0)
400 error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)",
401 ndimensions, MAX_FORTRAN_DIMS);
403 /* Since F77 arrays are stored column-major, we set up an
404 offset table to get at the various row's elements. The
405 offset table contains entries for both offset and subarray size. */
407 f77_create_arrayprint_offset_tbl (type, stream);
409 f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
410 deref_ref, recurse, pretty);
414 /* Print data of type TYPE located at VALADDR (within GDB), which came from
415 the inferior at address ADDRESS, onto stdio stream STREAM according to
416 FORMAT (a letter or 0 for natural format). The data at VALADDR is in
419 If the data are a string pointer, returns the number of string characters
422 If DEREF_REF is nonzero, then dereference references, otherwise just print
425 The PRETTY parameter controls prettyprinting. */
428 f_val_print (type, valaddr, address, stream, format, deref_ref, recurse,
437 enum val_prettyprint pretty;
439 register unsigned int i = 0; /* Number of characters printed */
441 struct type *elttype;
447 switch (TYPE_CODE (type))
449 case TYPE_CODE_LITERAL_STRING:
450 /* It is trivial to print out F77 strings allocated in the
451 superior process. The address field is actually a
452 pointer to the bytes of the literal. For an internalvar,
453 valaddr points to a ptr. which points to
454 VALUE_LITERAL_DATA(value->internalvar->value)
455 and for straight literals (i.e. of the form 'hello world'),
456 valaddr points a ptr to VALUE_LITERAL_DATA(value). */
458 /* First dereference valaddr. */
460 straddr = * (CORE_ADDR *) valaddr;
464 len = TYPE_LENGTH (type);
465 localstr = alloca (len + 1);
466 strncpy (localstr, straddr, len);
467 localstr[len] = '\0';
468 fprintf_filtered (stream, "'%s'", localstr);
471 fprintf_filtered (stream, "Unable to print literal F77 string");
474 /* Strings are a little bit funny. They can be viewed as
475 monolithic arrays that are dealt with as atomic data
476 items. As such they are the only atomic data items whose
477 contents are not located in the superior process. Instead
478 instead of having the actual data, they contain pointers
479 to addresses in the inferior where data is located. Thus
480 instead of using valaddr, we use address. */
482 case TYPE_CODE_STRING:
483 f77_get_dynamic_length_of_aggregate (type);
484 val_print_string (address, TYPE_LENGTH (type), stream);
487 case TYPE_CODE_ARRAY:
488 fprintf_filtered (stream, "(");
489 f77_print_array (type, valaddr, address, stream, format,
490 deref_ref, recurse, pretty);
491 fprintf_filtered (stream, ")");
494 /* Array of unspecified length: treat like pointer to first elt. */
495 valaddr = (char *) &address;
499 if (format && format != 's')
501 print_scalar_formatted (valaddr, type, format, 0, stream);
506 addr = unpack_pointer (type, valaddr);
507 elttype = TYPE_TARGET_TYPE (type);
509 if (TYPE_CODE (elttype) == TYPE_CODE_FUNC)
511 /* Try to print what function it points to. */
512 print_address_demangle (addr, stream, demangle);
513 /* Return value is irrelevant except for string pointers. */
517 if (addressprint && format != 's')
518 fprintf_filtered (stream, "0x%x", addr);
520 /* For a pointer to char or unsigned char, also print the string
521 pointed to, unless pointer is null. */
522 if (TYPE_LENGTH (elttype) == 1
523 && TYPE_CODE (elttype) == TYPE_CODE_INT
524 && (format == 0 || format == 's')
526 i = val_print_string (addr, 0, stream);
528 /* Return number of characters printed, plus one for the
529 terminating null if we have "reached the end". */
530 return (i + (print_max && i != print_max));
537 print_scalar_formatted (valaddr, type, format, 0, stream);
540 /* FIXME, we should consider, at least for ANSI C language, eliminating
541 the distinction made between FUNCs and POINTERs to FUNCs. */
542 fprintf_filtered (stream, "{");
543 type_print (type, "", stream, -1);
544 fprintf_filtered (stream, "} ");
545 /* Try to print what function it points to, and its address. */
546 print_address_demangle (address, stream, demangle);
550 format = format ? format : output_format;
552 print_scalar_formatted (valaddr, type, format, 0, stream);
555 val_print_type_code_int (type, valaddr, stream);
556 /* C and C++ has no single byte int type, char is used instead.
557 Since we don't know whether the value is really intended to
558 be used as an integer or a character, print the character
559 equivalent as well. */
560 if (TYPE_LENGTH (type) == 1)
562 fputs_filtered (" ", stream);
563 LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr),
571 print_scalar_formatted (valaddr, type, format, 0, stream);
573 print_floating (valaddr, type, stream);
577 fprintf_filtered (stream, "VOID");
580 case TYPE_CODE_ERROR:
581 fprintf_filtered (stream, "<error type>");
584 case TYPE_CODE_RANGE:
585 /* FIXME, we should not ever have to print one of these yet. */
586 fprintf_filtered (stream, "<range type>");
590 format = format ? format : output_format;
592 print_scalar_formatted (valaddr, type, format, 0, stream);
596 switch (TYPE_LENGTH(type))
599 val = unpack_long (builtin_type_f_logical_s1, valaddr);
603 val = unpack_long (builtin_type_f_logical_s2, valaddr);
607 val = unpack_long (builtin_type_f_logical, valaddr);
611 error ("Logicals of length %d bytes not supported",
617 fprintf_filtered (stream, ".FALSE.");
620 fprintf_filtered (stream, ".TRUE.");
622 /* Not a legitimate logical type, print as an integer. */
624 /* Bash the type code temporarily. */
625 TYPE_CODE (type) = TYPE_CODE_INT;
626 f_val_print (type, valaddr, address, stream, format,
627 deref_ref, recurse, pretty);
628 /* Restore the type code so later uses work as intended. */
629 TYPE_CODE (type) = TYPE_CODE_BOOL;
634 case TYPE_CODE_LITERAL_COMPLEX:
635 /* We know that the literal complex is stored in the superior
636 process not the inferior and that it is 16 bytes long.
637 Just like the case above with a literal array, the
638 bytes for the the literal complex number are stored
639 at the address pointed to by valaddr */
641 if (TYPE_LENGTH (type) == 32)
642 error ("Cannot currently print out complex*32 literals");
644 /* First dereference valaddr. */
646 addr = * (CORE_ADDR *) valaddr;
650 fprintf_filtered (stream, "(");
652 if (TYPE_LENGTH(type) == 16)
654 fprintf_filtered (stream, "%.16f", * (double *) addr);
655 fprintf_filtered (stream, ", %.16f", * (double *)
656 (addr + sizeof(double)));
660 fprintf_filtered (stream, "%.8f", * (float *) addr);
661 fprintf_filtered (stream, ", %.8f", * (float *)
662 (addr + sizeof(float)));
664 fprintf_filtered (stream, ") ");
667 fprintf_filtered (stream, "Unable to print literal F77 array");
670 case TYPE_CODE_COMPLEX:
671 switch (TYPE_LENGTH (type))
674 f77_print_cmplx (valaddr, type, stream, TARGET_COMPLEX_BIT);
678 f77_print_cmplx(valaddr, type, stream, TARGET_DOUBLE_COMPLEX_BIT);
682 f77_print_cmplx(valaddr, type, stream, TARGET_EXT_COMPLEX_BIT);
686 error ("Cannot print out complex*%d variables", TYPE_LENGTH(type));
690 case TYPE_CODE_UNDEF:
691 /* This happens (without TYPE_FLAG_STUB set) on systems which don't use
692 dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar"
693 and no complete type for struct foo in that file. */
694 fprintf_filtered (stream, "<incomplete type>");
698 error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type));
705 list_all_visible_commons (funname)
708 SAVED_F77_COMMON_PTR tmp;
710 tmp = head_common_list;
712 printf_filtered ("All COMMON blocks visible at this level:\n\n");
716 if (STREQ(tmp->owning_function,funname))
717 printf_filtered ("%s\n", tmp->name);
723 /* This function is used to print out the values in a given COMMON
724 block. It will always use the most local common block of the
728 info_common_command (comname, from_tty)
732 SAVED_F77_COMMON_PTR the_common;
733 COMMON_ENTRY_PTR entry;
734 struct frame_info *fi;
735 register char *funname = 0;
738 /* We have been told to display the contents of F77 COMMON
739 block supposedly visible in this function. Let us
740 first make sure that it is visible and if so, let
741 us display its contents */
746 error ("No frame selected");
748 /* The following is generally ripped off from stack.c's routine
749 print_frame_info() */
751 func = find_pc_function (fi->pc);
754 /* In certain pathological cases, the symtabs give the wrong
755 function (when we are in the first function in a file which
756 is compiled without debugging symbols, the previous function
757 is compiled with debugging symbols, and the "foo.o" symbol
758 that is supposed to tell us where the file with debugging symbols
759 ends has been truncated by ar because it is longer than 15
762 So look in the minimal symbol tables as well, and if it comes
763 up with a larger address for the function use that instead.
764 I don't think this can ever cause any problems; there shouldn't
765 be any minimal symbols in the middle of a function.
766 FIXME: (Not necessarily true. What about text labels) */
768 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
771 && (SYMBOL_VALUE_ADDRESS (msymbol)
772 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
773 funname = SYMBOL_NAME (msymbol);
775 funname = SYMBOL_NAME (func);
779 register struct minimal_symbol *msymbol =
780 lookup_minimal_symbol_by_pc (fi->pc);
783 funname = SYMBOL_NAME (msymbol);
786 /* If comnname is NULL, we assume the user wishes to see the
787 which COMMON blocks are visible here and then return */
789 if (strlen (comname) == 0)
791 list_all_visible_commons (funname);
795 the_common = find_common_for_function (comname,funname);
799 if (STREQ(comname,BLANK_COMMON_NAME_LOCAL))
800 printf_filtered ("Contents of blank COMMON block:\n");
802 printf_filtered ("Contents of F77 COMMON block '%s':\n",comname);
804 printf_filtered ("\n");
805 entry = the_common->entries;
807 while (entry != NULL)
809 printf_filtered ("%s = ",SYMBOL_NAME(entry->symbol));
810 print_variable_value (entry->symbol,fi,stdout);
811 printf_filtered ("\n");
816 printf_filtered ("Cannot locate the common block %s in function '%s'\n",
820 /* This function is used to determine whether there is a
821 F77 common block visible at the current scope called 'comname'. */
824 there_is_a_visible_common_named (comname)
827 SAVED_F77_COMMON_PTR the_common;
828 struct frame_info *fi;
829 register char *funname = 0;
833 error ("Cannot deal with NULL common name!");
838 error ("No frame selected");
840 /* The following is generally ripped off from stack.c's routine
841 print_frame_info() */
843 func = find_pc_function (fi->pc);
846 /* In certain pathological cases, the symtabs give the wrong
847 function (when we are in the first function in a file which
848 is compiled without debugging symbols, the previous function
849 is compiled with debugging symbols, and the "foo.o" symbol
850 that is supposed to tell us where the file with debugging symbols
851 ends has been truncated by ar because it is longer than 15
854 So look in the minimal symbol tables as well, and if it comes
855 up with a larger address for the function use that instead.
856 I don't think this can ever cause any problems; there shouldn't
857 be any minimal symbols in the middle of a function.
858 FIXME: (Not necessarily true. What about text labels) */
860 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
863 && (SYMBOL_VALUE_ADDRESS (msymbol)
864 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
865 funname = SYMBOL_NAME (msymbol);
867 funname = SYMBOL_NAME (func);
871 register struct minimal_symbol *msymbol =
872 lookup_minimal_symbol_by_pc (fi->pc);
875 funname = SYMBOL_NAME (msymbol);
878 the_common = find_common_for_function (comname, funname);
880 return (the_common ? 1 : 0);
884 _initialize_f_valprint ()
886 add_info ("common", info_common_command,
887 "Print out the values contained in a Fortran COMMON block.");