diff options
Diffstat (limited to 'gdb/f-valprint.c')
| -rw-r--r-- | gdb/f-valprint.c | 767 |
1 files changed, 767 insertions, 0 deletions
diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c new file mode 100644 index 00000000000..bb0b1d0efb1 --- /dev/null +++ b/gdb/f-valprint.c @@ -0,0 +1,767 @@ +/* Support for printing Fortran values for GDB, the GNU debugger. + Copyright 1993, 1994, 1995 Free Software Foundation, Inc. + Contributed by Motorola. Adapted from the C definitions by Farooq Butt + (fmbutt@engage.sps.mot.com), additionally worked over by Stan Shebs. + +This file is part of GDB. + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this program; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ + +#include "defs.h" +#include "gdb_string.h" +#include "symtab.h" +#include "gdbtypes.h" +#include "expression.h" +#include "value.h" +#include "demangle.h" +#include "valprint.h" +#include "language.h" +#include "f-lang.h" +#include "frame.h" +#include "gdbcore.h" +#include "command.h" + +#if 0 +static int there_is_a_visible_common_named PARAMS ((char *)); +#endif + +static void info_common_command PARAMS ((char *, int)); +static void list_all_visible_commons PARAMS ((char *)); +static void f77_print_array PARAMS ((struct type *, char *, CORE_ADDR, + GDB_FILE *, int, int, int, + enum val_prettyprint)); +static void f77_print_array_1 PARAMS ((int, int, struct type *, char *, + CORE_ADDR, GDB_FILE *, int, int, int, + enum val_prettyprint)); +static void f77_create_arrayprint_offset_tbl PARAMS ((struct type *, + GDB_FILE *)); +static void f77_get_dynamic_length_of_aggregate PARAMS ((struct type *)); + +int f77_array_offset_tbl[MAX_FORTRAN_DIMS+1][2]; + +/* Array which holds offsets to be applied to get a row's elements + for a given array. Array also holds the size of each subarray. */ + +/* The following macro gives us the size of the nth dimension, Where + n is 1 based. */ + +#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1]) + +/* The following gives us the offset for row n where n is 1-based. */ + +#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0]) + +int +f77_get_dynamic_lowerbound (type, lower_bound) + struct type *type; + int *lower_bound; +{ + CORE_ADDR current_frame_addr; + CORE_ADDR ptr_to_lower_bound; + + switch (TYPE_ARRAY_LOWER_BOUND_TYPE (type)) + { + case BOUND_BY_VALUE_ON_STACK: + current_frame_addr = selected_frame->frame; + if (current_frame_addr > 0) + { + *lower_bound = + read_memory_integer (current_frame_addr + + TYPE_ARRAY_LOWER_BOUND_VALUE (type), + 4); + } + else + { + *lower_bound = DEFAULT_LOWER_BOUND; + return BOUND_FETCH_ERROR; + } + break; + + case BOUND_SIMPLE: + *lower_bound = TYPE_ARRAY_LOWER_BOUND_VALUE (type); + break; + + case BOUND_CANNOT_BE_DETERMINED: + error ("Lower bound may not be '*' in F77"); + break; + + case BOUND_BY_REF_ON_STACK: + current_frame_addr = selected_frame->frame; + if (current_frame_addr > 0) + { + ptr_to_lower_bound = + read_memory_integer (current_frame_addr + + TYPE_ARRAY_LOWER_BOUND_VALUE (type), + 4); + *lower_bound = read_memory_integer (ptr_to_lower_bound, 4); + } + else + { + *lower_bound = DEFAULT_LOWER_BOUND; + return BOUND_FETCH_ERROR; + } + break; + + case BOUND_BY_REF_IN_REG: + case BOUND_BY_VALUE_IN_REG: + default: + error ("??? unhandled dynamic array bound type ???"); + break; + } + return BOUND_FETCH_OK; +} + +int +f77_get_dynamic_upperbound (type, upper_bound) + struct type *type; + int *upper_bound; +{ + CORE_ADDR current_frame_addr = 0; + CORE_ADDR ptr_to_upper_bound; + + switch (TYPE_ARRAY_UPPER_BOUND_TYPE (type)) + { + case BOUND_BY_VALUE_ON_STACK: + current_frame_addr = selected_frame->frame; + if (current_frame_addr > 0) + { + *upper_bound = + read_memory_integer (current_frame_addr + + TYPE_ARRAY_UPPER_BOUND_VALUE (type), + 4); + } + else + { + *upper_bound = DEFAULT_UPPER_BOUND; + return BOUND_FETCH_ERROR; + } + break; + + case BOUND_SIMPLE: + *upper_bound = TYPE_ARRAY_UPPER_BOUND_VALUE (type); + break; + + case BOUND_CANNOT_BE_DETERMINED: + /* we have an assumed size array on our hands. Assume that + upper_bound == lower_bound so that we show at least + 1 element.If the user wants to see more elements, let + him manually ask for 'em and we'll subscript the + array and show him */ + f77_get_dynamic_lowerbound (type, upper_bound); + break; + + case BOUND_BY_REF_ON_STACK: + current_frame_addr = selected_frame->frame; + if (current_frame_addr > 0) + { + ptr_to_upper_bound = + read_memory_integer (current_frame_addr + + TYPE_ARRAY_UPPER_BOUND_VALUE (type), + 4); + *upper_bound = read_memory_integer(ptr_to_upper_bound, 4); + } + else + { + *upper_bound = DEFAULT_UPPER_BOUND; + return BOUND_FETCH_ERROR; + } + break; + + case BOUND_BY_REF_IN_REG: + case BOUND_BY_VALUE_IN_REG: + default: + error ("??? unhandled dynamic array bound type ???"); + break; + } + return BOUND_FETCH_OK; +} + +/* Obtain F77 adjustable array dimensions */ + +static void +f77_get_dynamic_length_of_aggregate (type) + struct type *type; +{ + int upper_bound = -1; + int lower_bound = 1; + int retcode; + + /* Recursively go all the way down into a possibly multi-dimensional + F77 array and get the bounds. For simple arrays, this is pretty + easy but when the bounds are dynamic, we must be very careful + to add up all the lengths correctly. Not doing this right + will lead to horrendous-looking arrays in parameter lists. + + This function also works for strings which behave very + similarly to arrays. */ + + if (TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_ARRAY + || TYPE_CODE(TYPE_TARGET_TYPE (type)) == TYPE_CODE_STRING) + f77_get_dynamic_length_of_aggregate (TYPE_TARGET_TYPE (type)); + + /* Recursion ends here, start setting up lengths. */ + retcode = f77_get_dynamic_lowerbound (type, &lower_bound); + if (retcode == BOUND_FETCH_ERROR) + error ("Cannot obtain valid array lower bound"); + + retcode = f77_get_dynamic_upperbound (type, &upper_bound); + if (retcode == BOUND_FETCH_ERROR) + error ("Cannot obtain valid array upper bound"); + + /* Patch in a valid length value. */ + + TYPE_LENGTH (type) = + (upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type))); +} + +/* Function that sets up the array offset,size table for the array + type "type". */ + +static void +f77_create_arrayprint_offset_tbl (type, stream) + struct type *type; + GDB_FILE *stream; +{ + struct type *tmp_type; + int eltlen; + int ndimen = 1; + int upper, lower, retcode; + + tmp_type = type; + + while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY)) + { + if (TYPE_ARRAY_UPPER_BOUND_TYPE (tmp_type) == BOUND_CANNOT_BE_DETERMINED) + fprintf_filtered (stream, "<assumed size array> "); + + retcode = f77_get_dynamic_upperbound (tmp_type, &upper); + if (retcode == BOUND_FETCH_ERROR) + error ("Cannot obtain dynamic upper bound"); + + retcode = f77_get_dynamic_lowerbound(tmp_type,&lower); + if (retcode == BOUND_FETCH_ERROR) + error("Cannot obtain dynamic lower bound"); + + F77_DIM_SIZE (ndimen) = upper - lower + 1; + + tmp_type = TYPE_TARGET_TYPE (tmp_type); + ndimen++; + } + + /* Now we multiply eltlen by all the offsets, so that later we + can print out array elements correctly. Up till now we + know an offset to apply to get the item but we also + have to know how much to add to get to the next item */ + + ndimen--; + eltlen = TYPE_LENGTH (tmp_type); + F77_DIM_OFFSET (ndimen) = eltlen; + while (--ndimen > 0) + { + eltlen *= F77_DIM_SIZE (ndimen + 1); + F77_DIM_OFFSET (ndimen) = eltlen; + } +} + +/* Actual function which prints out F77 arrays, Valaddr == address in + the superior. Address == the address in the inferior. */ + +static void +f77_print_array_1 (nss, ndimensions, type, valaddr, address, + stream, format, deref_ref, recurse, pretty) + int nss; + int ndimensions; + struct type *type; + char *valaddr; + CORE_ADDR address; + GDB_FILE *stream; + int format; + int deref_ref; + int recurse; + enum val_prettyprint pretty; +{ + int i; + + if (nss != ndimensions) + { + for (i = 0; i< F77_DIM_SIZE(nss); i++) + { + fprintf_filtered (stream, "( "); + f77_print_array_1 (nss + 1, ndimensions, TYPE_TARGET_TYPE (type), + valaddr + i * F77_DIM_OFFSET (nss), + address + i * F77_DIM_OFFSET (nss), + stream, format, deref_ref, recurse, pretty); + fprintf_filtered (stream, ") "); + } + } + else + { + for (i = 0; (i < F77_DIM_SIZE (nss) && i < print_max); i++) + { + val_print (TYPE_TARGET_TYPE (type), + valaddr + i * F77_DIM_OFFSET (ndimensions), + 0, + address + i * F77_DIM_OFFSET (ndimensions), + stream, format, deref_ref, recurse, pretty); + + if (i != (F77_DIM_SIZE (nss) - 1)) + fprintf_filtered (stream, ", "); + + if (i == print_max - 1) + fprintf_filtered (stream, "..."); + } + } +} + +/* This function gets called to print an F77 array, we set up some + stuff and then immediately call f77_print_array_1() */ + +static void +f77_print_array (type, valaddr, address, stream, format, deref_ref, recurse, + pretty) + struct type *type; + char *valaddr; + CORE_ADDR address; + GDB_FILE *stream; + int format; + int deref_ref; + int recurse; + enum val_prettyprint pretty; +{ + int ndimensions; + + ndimensions = calc_f77_array_dims (type); + + if (ndimensions > MAX_FORTRAN_DIMS || ndimensions < 0) + error ("Type node corrupt! F77 arrays cannot have %d subscripts (%d Max)", + ndimensions, MAX_FORTRAN_DIMS); + + /* Since F77 arrays are stored column-major, we set up an + offset table to get at the various row's elements. The + offset table contains entries for both offset and subarray size. */ + + f77_create_arrayprint_offset_tbl (type, stream); + + f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format, + deref_ref, recurse, pretty); +} + + +/* Print data of type TYPE located at VALADDR (within GDB), which came from + the inferior at address ADDRESS, onto stdio stream STREAM according to + FORMAT (a letter or 0 for natural format). The data at VALADDR is in + target byte order. + + If the data are a string pointer, returns the number of string characters + printed. + + If DEREF_REF is nonzero, then dereference references, otherwise just print + them like pointers. + + The PRETTY parameter controls prettyprinting. */ + +int +f_val_print (type, valaddr, embedded_offset, address, stream, format, deref_ref, recurse, + pretty) + struct type *type; + char *valaddr; + int embedded_offset; + CORE_ADDR address; + GDB_FILE *stream; + int format; + int deref_ref; + int recurse; + enum val_prettyprint pretty; +{ + register unsigned int i = 0; /* Number of characters printed */ + struct type *elttype; + LONGEST val; + CORE_ADDR addr; + + CHECK_TYPEDEF (type); + switch (TYPE_CODE (type)) + { + case TYPE_CODE_STRING: + f77_get_dynamic_length_of_aggregate (type); + LA_PRINT_STRING (stream, valaddr, TYPE_LENGTH (type), 1, 0); + break; + + case TYPE_CODE_ARRAY: + fprintf_filtered (stream, "("); + f77_print_array (type, valaddr, address, stream, format, + deref_ref, recurse, pretty); + fprintf_filtered (stream, ")"); + break; +#if 0 + /* Array of unspecified length: treat like pointer to first elt. */ + valaddr = (char *) &address; + /* FALL THROUGH */ +#endif + case TYPE_CODE_PTR: + if (format && format != 's') + { + print_scalar_formatted (valaddr, type, format, 0, stream); + break; + } + else + { + addr = unpack_pointer (type, valaddr); + elttype = check_typedef (TYPE_TARGET_TYPE (type)); + + if (TYPE_CODE (elttype) == TYPE_CODE_FUNC) + { + /* Try to print what function it points to. */ + print_address_demangle (addr, stream, demangle); + /* Return value is irrelevant except for string pointers. */ + return 0; + } + + if (addressprint && format != 's') + fprintf_filtered (stream, "0x%x", addr); + + /* For a pointer to char or unsigned char, also print the string + pointed to, unless pointer is null. */ + if (TYPE_LENGTH (elttype) == 1 + && TYPE_CODE (elttype) == TYPE_CODE_INT + && (format == 0 || format == 's') + && addr != 0) + i = val_print_string (addr, -1, TYPE_LENGTH (elttype), stream); + + /* Return number of characters printed, plus one for the + terminating null if we have "reached the end". */ + return (i + (print_max && i != print_max)); + } + break; + + case TYPE_CODE_FUNC: + if (format) + { + print_scalar_formatted (valaddr, type, format, 0, stream); + break; + } + /* FIXME, we should consider, at least for ANSI C language, eliminating + the distinction made between FUNCs and POINTERs to FUNCs. */ + fprintf_filtered (stream, "{"); + type_print (type, "", stream, -1); + fprintf_filtered (stream, "} "); + /* Try to print what function it points to, and its address. */ + print_address_demangle (address, stream, demangle); + break; + + case TYPE_CODE_INT: + format = format ? format : output_format; + if (format) + print_scalar_formatted (valaddr, type, format, 0, stream); + else + { + val_print_type_code_int (type, valaddr, stream); + /* C and C++ has no single byte int type, char is used instead. + Since we don't know whether the value is really intended to + be used as an integer or a character, print the character + equivalent as well. */ + if (TYPE_LENGTH (type) == 1) + { + fputs_filtered (" ", stream); + LA_PRINT_CHAR ((unsigned char) unpack_long (type, valaddr), + stream); + } + } + break; + + case TYPE_CODE_FLT: + if (format) + print_scalar_formatted (valaddr, type, format, 0, stream); + else + print_floating (valaddr, type, stream); + break; + + case TYPE_CODE_VOID: + fprintf_filtered (stream, "VOID"); + break; + + case TYPE_CODE_ERROR: + fprintf_filtered (stream, "<error type>"); + break; + + case TYPE_CODE_RANGE: + /* FIXME, we should not ever have to print one of these yet. */ + fprintf_filtered (stream, "<range type>"); + break; + + case TYPE_CODE_BOOL: + format = format ? format : output_format; + if (format) + print_scalar_formatted (valaddr, type, format, 0, stream); + else + { + val = 0; + switch (TYPE_LENGTH(type)) + { + case 1: + val = unpack_long (builtin_type_f_logical_s1, valaddr); + break ; + + case 2: + val = unpack_long (builtin_type_f_logical_s2, valaddr); + break ; + + case 4: + val = unpack_long (builtin_type_f_logical, valaddr); + break ; + + default: + error ("Logicals of length %d bytes not supported", + TYPE_LENGTH (type)); + + } + + if (val == 0) + fprintf_filtered (stream, ".FALSE."); + else + if (val == 1) + fprintf_filtered (stream, ".TRUE."); + else + /* Not a legitimate logical type, print as an integer. */ + { + /* Bash the type code temporarily. */ + TYPE_CODE (type) = TYPE_CODE_INT; + f_val_print (type, valaddr, 0, address, stream, format, + deref_ref, recurse, pretty); + /* Restore the type code so later uses work as intended. */ + TYPE_CODE (type) = TYPE_CODE_BOOL; + } + } + break; + + case TYPE_CODE_COMPLEX: + switch (TYPE_LENGTH (type)) + { + case 8: type = builtin_type_f_real; break; + case 16: type = builtin_type_f_real_s8; break; + case 32: type = builtin_type_f_real_s16; break; + default: + error ("Cannot print out complex*%d variables", TYPE_LENGTH(type)); + } + fputs_filtered ("(", stream); + print_floating (valaddr, type, stream); + fputs_filtered (",", stream); + print_floating (valaddr, type, stream); + fputs_filtered (")", stream); + break; + + case TYPE_CODE_UNDEF: + /* This happens (without TYPE_FLAG_STUB set) on systems which don't use + dbx xrefs (NO_DBX_XREFS in gcc) if a file has a "struct foo *bar" + and no complete type for struct foo in that file. */ + fprintf_filtered (stream, "<incomplete type>"); + break; + + default: + error ("Invalid F77 type code %d in symbol table.", TYPE_CODE (type)); + } + gdb_flush (stream); + return 0; +} + +static void +list_all_visible_commons (funname) + char *funname; +{ + SAVED_F77_COMMON_PTR tmp; + + tmp = head_common_list; + + printf_filtered ("All COMMON blocks visible at this level:\n\n"); + + while (tmp != NULL) + { + if (STREQ(tmp->owning_function,funname)) + printf_filtered ("%s\n", tmp->name); + + tmp = tmp->next; + } +} + +/* This function is used to print out the values in a given COMMON + block. It will always use the most local common block of the + given name */ + +static void +info_common_command (comname, from_tty) + char *comname; + int from_tty; +{ + SAVED_F77_COMMON_PTR the_common; + COMMON_ENTRY_PTR entry; + struct frame_info *fi; + register char *funname = 0; + struct symbol *func; + + /* We have been told to display the contents of F77 COMMON + block supposedly visible in this function. Let us + first make sure that it is visible and if so, let + us display its contents */ + + fi = selected_frame; + + if (fi == NULL) + error ("No frame selected"); + + /* The following is generally ripped off from stack.c's routine + print_frame_info() */ + + func = find_pc_function (fi->pc); + if (func) + { + /* In certain pathological cases, the symtabs give the wrong + function (when we are in the first function in a file which + is compiled without debugging symbols, the previous function + is compiled with debugging symbols, and the "foo.o" symbol + that is supposed to tell us where the file with debugging symbols + ends has been truncated by ar because it is longer than 15 + characters). + + So look in the minimal symbol tables as well, and if it comes + up with a larger address for the function use that instead. + I don't think this can ever cause any problems; there shouldn't + be any minimal symbols in the middle of a function. + FIXME: (Not necessarily true. What about text labels) */ + + struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc); + + if (msymbol != NULL + && (SYMBOL_VALUE_ADDRESS (msymbol) + > BLOCK_START (SYMBOL_BLOCK_VALUE (func)))) + funname = SYMBOL_NAME (msymbol); + else + funname = SYMBOL_NAME (func); + } + else + { + register struct minimal_symbol *msymbol = + lookup_minimal_symbol_by_pc (fi->pc); + + if (msymbol != NULL) + funname = SYMBOL_NAME (msymbol); + } + + /* If comname is NULL, we assume the user wishes to see the + which COMMON blocks are visible here and then return */ + + if (comname == 0) + { + list_all_visible_commons (funname); + return; + } + + the_common = find_common_for_function (comname,funname); + + if (the_common) + { + if (STREQ(comname,BLANK_COMMON_NAME_LOCAL)) + printf_filtered ("Contents of blank COMMON block:\n"); + else + printf_filtered ("Contents of F77 COMMON block '%s':\n",comname); + + printf_filtered ("\n"); + entry = the_common->entries; + + while (entry != NULL) + { + printf_filtered ("%s = ",SYMBOL_NAME(entry->symbol)); + print_variable_value (entry->symbol, fi, gdb_stdout); + printf_filtered ("\n"); + entry = entry->next; + } + } + else + printf_filtered ("Cannot locate the common block %s in function '%s'\n", + comname, funname); +} + +/* This function is used to determine whether there is a + F77 common block visible at the current scope called 'comname'. */ + +#if 0 +static int +there_is_a_visible_common_named (comname) + char *comname; +{ + SAVED_F77_COMMON_PTR the_common; + struct frame_info *fi; + register char *funname = 0; + struct symbol *func; + + if (comname == NULL) + error ("Cannot deal with NULL common name!"); + + fi = selected_frame; + + if (fi == NULL) + error ("No frame selected"); + + /* The following is generally ripped off from stack.c's routine + print_frame_info() */ + + func = find_pc_function (fi->pc); + if (func) + { + /* In certain pathological cases, the symtabs give the wrong + function (when we are in the first function in a file which + is compiled without debugging symbols, the previous function + is compiled with debugging symbols, and the "foo.o" symbol + that is supposed to tell us where the file with debugging symbols + ends has been truncated by ar because it is longer than 15 + characters). + + So look in the minimal symbol tables as well, and if it comes + up with a larger address for the function use that instead. + I don't think this can ever cause any problems; there shouldn't + be any minimal symbols in the middle of a function. + FIXME: (Not necessarily true. What about text labels) */ + + struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc); + + if (msymbol != NULL + && (SYMBOL_VALUE_ADDRESS (msymbol) + > BLOCK_START (SYMBOL_BLOCK_VALUE (func)))) + funname = SYMBOL_NAME (msymbol); + else + funname = SYMBOL_NAME (func); + } + else + { + register struct minimal_symbol *msymbol = + lookup_minimal_symbol_by_pc (fi->pc); + + if (msymbol != NULL) + funname = SYMBOL_NAME (msymbol); + } + + the_common = find_common_for_function (comname, funname); + + return (the_common ? 1 : 0); +} +#endif + +void +_initialize_f_valprint () +{ + add_info ("common", info_common_command, + "Print out the values contained in a Fortran COMMON block."); + if (xdb_commands) + add_com("lc", class_info, info_common_command, + "Print out the values contained in a Fortran COMMON block."); +} |