#include "defs.h"
#include "gdb_string.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "value.h"
#include "valprint.h"
#include "language.h"
#include "f-lang.h"
#include "frame.h"
#include "gdbcore.h"
#include "command.h"
#include "block.h"
#if 0
static int there_is_a_visible_common_named (char *);
#endif
extern void _initialize_f_valprint (void);
static void info_common_command (char *, int);
static void list_all_visible_commons (char *);
static void f77_print_array (struct type *, char *, CORE_ADDR,
struct ui_file *, int, int, int,
enum val_prettyprint);
static void f77_print_array_1 (int, int, struct type *, char *,
CORE_ADDR, struct ui_file *, int, int, int,
enum val_prettyprint,
int *elts);
static void f77_create_arrayprint_offset_tbl (struct type *,
struct ui_file *);
static void f77_get_dynamic_length_of_aggregate (struct type *);
int f77_array_offset_tbl[MAX_FORTRAN_DIMS + 1][2];
#define F77_DIM_SIZE(n) (f77_array_offset_tbl[n][1])
#define F77_DIM_OFFSET(n) (f77_array_offset_tbl[n][0])
int
f77_get_dynamic_lowerbound (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 = get_frame_base (deprecated_selected_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 = get_frame_base (deprecated_selected_frame);
if (current_frame_addr > 0)
{
ptr_to_lower_bound =
read_memory_typed_address (current_frame_addr +
TYPE_ARRAY_LOWER_BOUND_VALUE (type),
builtin_type_void_data_ptr);
*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 (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 = get_frame_base (deprecated_selected_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:
f77_get_dynamic_lowerbound (type, upper_bound);
break;
case BOUND_BY_REF_ON_STACK:
current_frame_addr = get_frame_base (deprecated_selected_frame);
if (current_frame_addr > 0)
{
ptr_to_upper_bound =
read_memory_typed_address (current_frame_addr +
TYPE_ARRAY_UPPER_BOUND_VALUE (type),
builtin_type_void_data_ptr);
*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;
}
static void
f77_get_dynamic_length_of_aggregate (struct type *type)
{
int upper_bound = -1;
int lower_bound = 1;
int retcode;
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));
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");
TYPE_LENGTH (type) =
(upper_bound - lower_bound + 1) * TYPE_LENGTH (check_typedef (TYPE_TARGET_TYPE (type)));
}
static void
f77_create_arrayprint_offset_tbl (struct type *type, struct ui_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++;
}
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;
}
}
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)
{
int i;
if (nss != ndimensions)
{
for (i = 0; (i < F77_DIM_SIZE (nss) && (*elts) < print_max); 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, elts);
fprintf_filtered (stream, ") ");
}
if (*elts >= print_max && i < F77_DIM_SIZE (nss))
fprintf_filtered (stream, "...");
}
else
{
for (i = 0; i < F77_DIM_SIZE (nss) && (*elts) < print_max;
i++, (*elts)++)
{
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 ((*elts == print_max - 1) && (i != (F77_DIM_SIZE (nss) - 1)))
fprintf_filtered (stream, "...");
}
}
}
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)
{
int ndimensions;
int elts = 0;
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);
f77_create_arrayprint_offset_tbl (type, stream);
f77_print_array_1 (1, ndimensions, type, valaddr, address, stream, format,
deref_ref, recurse, pretty, &elts);
}
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)
{
unsigned int i = 0;
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;
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)
{
print_address_demangle (addr, stream, demangle);
return 0;
}
if (addressprint && format != 's')
print_address_numeric (addr, 1, stream);
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 i;
}
break;
case TYPE_CODE_REF:
elttype = check_typedef (TYPE_TARGET_TYPE (type));
if (addressprint)
{
CORE_ADDR addr
= extract_typed_address (valaddr + embedded_offset, type);
fprintf_filtered (stream, "@");
print_address_numeric (addr, 1, stream);
if (deref_ref)
fputs_filtered (": ", stream);
}
if (deref_ref)
{
if (TYPE_CODE (elttype) != TYPE_CODE_UNDEF)
{
struct value *deref_val =
value_at
(TYPE_TARGET_TYPE (type),
unpack_pointer (lookup_pointer_type (builtin_type_void),
valaddr + embedded_offset),
NULL);
val_print (VALUE_TYPE (deref_val),
VALUE_CONTENTS (deref_val),
0,
VALUE_ADDRESS (deref_val),
stream,
format,
deref_ref,
recurse,
pretty);
}
else
fputs_filtered ("???", stream);
}
break;
case TYPE_CODE_FUNC:
if (format)
{
print_scalar_formatted (valaddr, type, format, 0, stream);
break;
}
fprintf_filtered (stream, "{");
type_print (type, "", stream, -1);
fprintf_filtered (stream, "} ");
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);
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, "<unknown type>");
break;
case TYPE_CODE_RANGE:
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
{
TYPE_CODE (type) = TYPE_CODE_INT;
f_val_print (type, valaddr, 0, address, stream, format,
deref_ref, recurse, pretty);
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_LENGTH (type), type, stream);
fputs_filtered (")", stream);
break;
case TYPE_CODE_UNDEF:
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 (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 (strcmp (tmp->owning_function, funname) == 0)
printf_filtered ("%s\n", tmp->name);
tmp = tmp->next;
}
}
static void
info_common_command (char *comname, int from_tty)
{
SAVED_F77_COMMON_PTR the_common;
COMMON_ENTRY_PTR entry;
struct frame_info *fi;
char *funname = 0;
struct symbol *func;
fi = deprecated_selected_frame;
if (fi == NULL)
error ("No frame selected");
func = find_pc_function (get_frame_pc (fi));
if (func)
{
struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (get_frame_pc (fi));
if (msymbol != NULL
&& (SYMBOL_VALUE_ADDRESS (msymbol)
> BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
funname = DEPRECATED_SYMBOL_NAME (msymbol);
else
funname = DEPRECATED_SYMBOL_NAME (func);
}
else
{
struct minimal_symbol *msymbol =
lookup_minimal_symbol_by_pc (get_frame_pc (fi));
if (msymbol != NULL)
funname = DEPRECATED_SYMBOL_NAME (msymbol);
}
if (comname == 0)
{
list_all_visible_commons (funname);
return;
}
the_common = find_common_for_function (comname, funname);
if (the_common)
{
if (strcmp (comname, BLANK_COMMON_NAME_LOCAL) == 0)
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 = ", DEPRECATED_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);
}
#if 0
static int
there_is_a_visible_common_named (char *comname)
{
SAVED_F77_COMMON_PTR the_common;
struct frame_info *fi;
char *funname = 0;
struct symbol *func;
if (comname == NULL)
error ("Cannot deal with NULL common name!");
fi = deprecated_selected_frame;
if (fi == NULL)
error ("No frame selected");
func = find_pc_function (fi->pc);
if (func)
{
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 = DEPRECATED_SYMBOL_NAME (msymbol);
else
funname = DEPRECATED_SYMBOL_NAME (func);
}
else
{
struct minimal_symbol *msymbol =
lookup_minimal_symbol_by_pc (fi->pc);
if (msymbol != NULL)
funname = DEPRECATED_SYMBOL_NAME (msymbol);
}
the_common = find_common_for_function (comname, funname);
return (the_common ? 1 : 0);
}
#endif
void
_initialize_f_valprint (void)
{
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.");
}