darkkirb/old-cross-binutils
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Initial Fortran language support, adapted from work by Farooq Butt

Browse source 
(fmbutt@engage.sps.mot.com).
	* Makefile.in: Add Fortran-related files and dependencies.
	* defs.h (language_fortran): New language enum.
	* language.h (_LANG_fortran): Define.
	(MAX_FORTRAN_DIMS): Define.
	* expression.h: Reformat to standard.
	(MULTI_F77_SUBSCRIPT, OP_F77_UNDETERMINED_ARGLIST,
	OP_F77_LITERAL_COMPLEX, OP_F77_SUBSTR): New expression opcodes.
	* gdbtypes.h (TYPE_CODE_COMPLEX, TYPE_CODE_LITERAL_COMPLEX,
	TYPE_CODE_LITERAL_STRING): New type codes.
	(type): New fields upper_bound_type and lower_bound_type.
	(TYPE_ARRAY_UPPER_BOUND_TYPE, TYPE_ARRAY_LOWER_BOUND_TYPE,
	TYPE_ARRAY_UPPER_BOUND_VALUE, TYPE_ARRAY_LOWER_BOUND_VALUE): New
	macros.
	(builtin_type_f_character, etc): Declare.
	* value.h (VALUE_LITERAL_DATA, VALUE_SUBSTRING_START): Define.
	* f-exp.y: New file, Fortran expression grammar.
	* f-lang.c: New file, Fortran language support functions.
	* f-lang.h: New file, Fortran language support declarations.
	* f-typeprint.c: New file, Fortran type printing.
	* f-valprint.c: New file, Fortran value printing.
	* eval.c (evaluate_subexp): Add code for new expression opcodes,
	fix wording of error message.
	* gdbtypes.c (f77_create_literal_complex_type,
	f77_create_literal_string_type): New functions.
	* language.c (set_language_command): Add Fortran info.
	(calc_f77_array_dims): New function.
	* parse.c (length_of_subexp, prefixify_subexp): Add cases for new
	expression opcodes.
	* symfile.c (deduce_language_from_filename): Recognize .f and .F
	as Fortran source files.
	* valops.c (f77_value_literal_string, f77_value_substring,
	f77_value_literal_complex): New functions.
This commit is contained in:
Stan Shebs 1994-08-19 21:59:05 +00:00
parent f3806e3b6c
commit a91a61923d
13 changed files with 4209 additions and 118 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

37
gdb/ChangeLog
View file

@ -1,3 +1,40 @@
Fri Aug 19 14:55:45 1994 Stan Shebs (shebs@andros.cygnus.com)
Initial Fortran language support, adapted from work by Farooq Butt
(fmbutt@engage.sps.mot.com).
* Makefile.in: Add Fortran-related files and dependencies.
* defs.h (language_fortran): New language enum.
* language.h (_LANG_fortran): Define.
(MAX_FORTRAN_DIMS): Define.
* expression.h: Reformat to standard.
(MULTI_F77_SUBSCRIPT, OP_F77_UNDETERMINED_ARGLIST,
OP_F77_LITERAL_COMPLEX, OP_F77_SUBSTR): New expression opcodes.
* gdbtypes.h (TYPE_CODE_COMPLEX, TYPE_CODE_LITERAL_COMPLEX,
TYPE_CODE_LITERAL_STRING): New type codes.
(type): New fields upper_bound_type and lower_bound_type.
(TYPE_ARRAY_UPPER_BOUND_TYPE, TYPE_ARRAY_LOWER_BOUND_TYPE,
TYPE_ARRAY_UPPER_BOUND_VALUE, TYPE_ARRAY_LOWER_BOUND_VALUE): New
macros.
(builtin_type_f_character, etc): Declare.
* value.h (VALUE_LITERAL_DATA, VALUE_SUBSTRING_START): Define.
* f-exp.y: New file, Fortran expression grammar.
* f-lang.c: New file, Fortran language support functions.
* f-lang.h: New file, Fortran language support declarations.
* f-typeprint.c: New file, Fortran type printing.
* f-valprint.c: New file, Fortran value printing.
* eval.c (evaluate_subexp): Add code for new expression opcodes,
fix wording of error message.
* gdbtypes.c (f77_create_literal_complex_type,
f77_create_literal_string_type): New functions.
* language.c (set_language_command): Add Fortran info.
(calc_f77_array_dims): New function.
* parse.c (length_of_subexp, prefixify_subexp): Add cases for new
expression opcodes.
* symfile.c (deduce_language_from_filename): Recognize .f and .F
as Fortran source files.
* valops.c (f77_value_literal_string, f77_value_substring,
f77_value_literal_complex): New functions.
Fri Aug 19 13:35:01 1994 Peter Schauer (pes@regent.e-technik.tu-muenchen.de)
* c-typeprint.c (c_print_type): Assume demangled arguments

1246
gdb/f-exp.y Normal file
View file

File diff suppressed because it is too large Load diff

945
gdb/f-lang.c Normal file
View file

@ -0,0 +1,945 @@
/* Fortran language support routines for GDB, the GNU debugger.
Copyright 1993, 1994 Free Software Foundation, Inc.
Contributed by Motorola. Adapted from the C parser by Farooq Butt
(fmbutt@engage.sps.mot.com).
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., 675 Mass Ave, Cambridge, MA 02139, USA. */
#include "defs.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
#include "f-lang.h"
/* Print the character C on STREAM as part of the contents of a literal
string whose delimiter is QUOTER. Note that that format for printing
characters and strings is language specific.
FIXME: This is a copy of the same function from c-exp.y. It should
be replaced with a true F77 version. */
static void
emit_char (c, stream, quoter)
register int c;
FILE *stream;
int quoter;
{
c &= 0xFF; /* Avoid sign bit follies */
if (PRINT_LITERAL_FORM (c))
{
if (c == '\\' || c == quoter)
fputs_filtered ("\\", stream);
fprintf_filtered (stream, "%c", c);
}
else
{
switch (c)
{
case '\n':
fputs_filtered ("\\n", stream);
break;
case '\b':
fputs_filtered ("\\b", stream);
break;
case '\t':
fputs_filtered ("\\t", stream);
break;
case '\f':
fputs_filtered ("\\f", stream);
break;
case '\r':
fputs_filtered ("\\r", stream);
break;
case '\033':
fputs_filtered ("\\e", stream);
break;
case '\007':
fputs_filtered ("\\a", stream);
break;
default:
fprintf_filtered (stream, "\\%.3o", (unsigned int) c);
break;
}
}
}
/* FIXME: This is a copy of the same function from c-exp.y. It should
be replaced with a true F77version. */
static void
f_printchar (c, stream)
int c;
FILE *stream;
{
fputs_filtered ("'", stream);
emit_char (c, stream, '\'');
fputs_filtered ("'", stream);
}
/* Print the character string STRING, printing at most LENGTH characters.
Printing stops early if the number hits print_max; repeat counts
are printed as appropriate. Print ellipses at the end if we
had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
FIXME: This is a copy of the same function from c-exp.y. It should
be replaced with a true F77 version. */
static void
f_printstr (stream, string, length, force_ellipses)
FILE *stream;
char *string;
unsigned int length;
int force_ellipses;
{
register unsigned int i;
unsigned int things_printed = 0;
int in_quotes = 0;
int need_comma = 0;
extern int inspect_it;
extern int repeat_count_threshold;
extern int print_max;
if (length == 0)
{
fputs_filtered ("''", stdout);
return;
}
for (i = 0; i < length && things_printed < print_max; ++i)
{
/* Position of the character we are examining
to see whether it is repeated. */
unsigned int rep1;
/* Number of repetitions we have detected so far. */
unsigned int reps;
QUIT;
if (need_comma)
{
fputs_filtered (", ", stream);
need_comma = 0;
}
rep1 = i + 1;
reps = 1;
while (rep1 < length && string[rep1] == string[i])
{
++rep1;
++reps;
}
if (reps > repeat_count_threshold)
{
if (in_quotes)
{
if (inspect_it)
fputs_filtered ("\\', ", stream);
else
fputs_filtered ("', ", stream);
in_quotes = 0;
}
f_printchar (string[i], stream);
fprintf_filtered (stream, " <repeats %u times>", reps);
i = rep1 - 1;
things_printed += repeat_count_threshold;
need_comma = 1;
}
else
{
if (!in_quotes)
{
if (inspect_it)
fputs_filtered ("\\'", stream);
else
fputs_filtered ("'", stream);
in_quotes = 1;
}
emit_char (string[i], stream, '"');
++things_printed;
}
}
/* Terminate the quotes if necessary. */
if (in_quotes)
{
if (inspect_it)
fputs_filtered ("\\'", stream);
else
fputs_filtered ("'", stream);
}
if (force_ellipses || i < length)
fputs_filtered ("...", stream);
}
/* FIXME: This is a copy of c_create_fundamental_type(), before
all the non-C types were stripped from it. Needs to be fixed
by an experienced F77 programmer. */
static struct type *
f_create_fundamental_type (objfile, typeid)
struct objfile *objfile;
int typeid;
{
register struct type *type = NULL;
switch (typeid)
{
case FT_VOID:
type = init_type (TYPE_CODE_VOID,
TARGET_CHAR_BIT / TARGET_CHAR_BIT,
0, "VOID", objfile);
break;
case FT_BOOLEAN:
type = init_type (TYPE_CODE_BOOL,
TARGET_CHAR_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED, "boolean", objfile);
break;
case FT_STRING:
type = init_type (TYPE_CODE_STRING,
TARGET_CHAR_BIT / TARGET_CHAR_BIT,
0, "string", objfile);
break;
case FT_CHAR:
type = init_type (TYPE_CODE_INT,
TARGET_CHAR_BIT / TARGET_CHAR_BIT,
0, "character", objfile);
break;
case FT_SIGNED_CHAR:
type = init_type (TYPE_CODE_INT,
TARGET_CHAR_BIT / TARGET_CHAR_BIT,
0, "integer*1", objfile);
break;
case FT_UNSIGNED_CHAR:
type = init_type (TYPE_CODE_BOOL,
TARGET_CHAR_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED, "logical*1", objfile);
break;
case FT_SHORT:
type = init_type (TYPE_CODE_INT,
TARGET_SHORT_BIT / TARGET_CHAR_BIT,
0, "integer*2", objfile);
break;
case FT_SIGNED_SHORT:
type = init_type (TYPE_CODE_INT,
TARGET_SHORT_BIT / TARGET_CHAR_BIT,
0, "short", objfile); /* FIXME-fnf */
break;
case FT_UNSIGNED_SHORT:
type = init_type (TYPE_CODE_BOOL,
TARGET_SHORT_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED, "logical*2", objfile);
break;
case FT_INTEGER:
type = init_type (TYPE_CODE_INT,
TARGET_INT_BIT / TARGET_CHAR_BIT,
0, "integer*4", objfile);
break;
case FT_SIGNED_INTEGER:
type = init_type (TYPE_CODE_INT,
TARGET_INT_BIT / TARGET_CHAR_BIT,
0, "integer", objfile); /* FIXME -fnf */
break;
case FT_UNSIGNED_INTEGER:
type = init_type (TYPE_CODE_BOOL,
TARGET_INT_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED, "logical*4", objfile);
break;
case FT_FIXED_DECIMAL:
type = init_type (TYPE_CODE_INT,
TARGET_INT_BIT / TARGET_CHAR_BIT,
0, "fixed decimal", objfile);
break;
case FT_LONG:
type = init_type (TYPE_CODE_INT,
TARGET_LONG_BIT / TARGET_CHAR_BIT,
0, "long", objfile);
break;
case FT_SIGNED_LONG:
type = init_type (TYPE_CODE_INT,
TARGET_LONG_BIT / TARGET_CHAR_BIT,
0, "long", objfile); /* FIXME -fnf */
break;
case FT_UNSIGNED_LONG:
type = init_type (TYPE_CODE_INT,
TARGET_LONG_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
break;
case FT_LONG_LONG:
type = init_type (TYPE_CODE_INT,
TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
0, "long long", objfile);
break;
case FT_SIGNED_LONG_LONG:
type = init_type (TYPE_CODE_INT,
TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
0, "signed long long", objfile);
break;
case FT_UNSIGNED_LONG_LONG:
type = init_type (TYPE_CODE_INT,
TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
break;
case FT_FLOAT:
type = init_type (TYPE_CODE_FLT,
TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
0, "real", objfile);
break;
case FT_DBL_PREC_FLOAT:
type = init_type (TYPE_CODE_FLT,
TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
0, "real*8", objfile);
break;
case FT_FLOAT_DECIMAL:
type = init_type (TYPE_CODE_FLT,
TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
0, "floating decimal", objfile);
break;
case FT_EXT_PREC_FLOAT:
type = init_type (TYPE_CODE_FLT,
TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
0, "real*16", objfile);
break;
case FT_COMPLEX:
type = init_type (TYPE_CODE_FLT,
TARGET_COMPLEX_BIT / TARGET_CHAR_BIT,
0, "complex*8", objfile);
break;
case FT_DBL_PREC_COMPLEX:
type = init_type (TYPE_CODE_FLT,
TARGET_DOUBLE_COMPLEX_BIT / TARGET_CHAR_BIT,
0, "complex*16", objfile);
break;
case FT_EXT_PREC_COMPLEX:
type = init_type (TYPE_CODE_FLT,
TARGET_DOUBLE_COMPLEX_BIT / TARGET_CHAR_BIT,
0, "complex*32", objfile);
break;
default:
/* FIXME: For now, if we are asked to produce a type not in this
language, create the equivalent of a C integer type with the
name "<?type?>". When all the dust settles from the type
reconstruction work, this should probably become an error. */
type = init_type (TYPE_CODE_INT,
TARGET_INT_BIT / TARGET_CHAR_BIT,
0, "<?type?>", objfile);
warning ("internal error: no F77 fundamental type %d", typeid);
break;
}
return (type);
}
/* Table of operators and their precedences for printing expressions. */
static const struct op_print f_op_print_tab[] = {
{ "+", BINOP_ADD, PREC_ADD, 0 },
{ "+", UNOP_PLUS, PREC_PREFIX, 0 },
{ "-", BINOP_SUB, PREC_ADD, 0 },
{ "-", UNOP_NEG, PREC_PREFIX, 0 },
{ "*", BINOP_MUL, PREC_MUL, 0 },
{ "/", BINOP_DIV, PREC_MUL, 0 },
{ "DIV", BINOP_INTDIV, PREC_MUL, 0 },
{ "MOD", BINOP_REM, PREC_MUL, 0 },
{ "=", BINOP_ASSIGN, PREC_ASSIGN, 1 },
{ ".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0 },
{ ".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0 },
{ ".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0 },
{ ".EQ.", BINOP_EQUAL, PREC_EQUAL, 0 },
{ ".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0 },
{ ".LE.", BINOP_LEQ, PREC_ORDER, 0 },
{ ".GE.", BINOP_GEQ, PREC_ORDER, 0 },
{ ".GT.", BINOP_GTR, PREC_ORDER, 0 },
{ ".LT.", BINOP_LESS, PREC_ORDER, 0 },
{ "**", UNOP_IND, PREC_PREFIX, 0 },
{ "@", BINOP_REPEAT, PREC_REPEAT, 0 },
{ NULL, 0, 0, 0 }
};
/* The built-in types of F77. */
struct type *builtin_type_f_character;
struct type *builtin_type_f_integer;
struct type *builtin_type_f_logical;
struct type *builtin_type_f_logical_s1;
struct type *builtin_type_f_logical_s2;
struct type *builtin_type_f_integer;
struct type *builtin_type_f_integer_s2;
struct type *builtin_type_f_real;
struct type *builtin_type_f_real_s8;
struct type *builtin_type_f_real_s16;
struct type *builtin_type_f_complex_s8;
struct type *builtin_type_f_complex_s16;
struct type *builtin_type_f_complex_s32;
struct type *builtin_type_f_void;
struct type ** const (f_builtin_types[]) =
{
&builtin_type_f_character,
&builtin_type_f_integer,
&builtin_type_f_logical,
&builtin_type_f_logical_s1,
&builtin_type_f_logical_s2,
&builtin_type_f_integer,
&builtin_type_f_integer_s2,
&builtin_type_f_real,
&builtin_type_f_real_s8,
&builtin_type_f_real_s16,
&builtin_type_f_complex_s8,
&builtin_type_f_complex_s16,
#if 0
&builtin_type_f_complex_s32,
#endif
&builtin_type_f_void,
0
};
int c_value_print();
const struct language_defn f_language_defn = {
"fortran",
language_fortran,
f_builtin_types,
range_check_on,
type_check_on,
f_parse, /* parser */
f_error, /* parser error function */
f_printchar, /* Print character constant */
f_printstr, /* function to print string constant */
f_create_fundamental_type, /* Create fundamental type in this language */
f_print_type, /* Print a type using appropriate syntax */
f_val_print, /* Print a value using appropriate syntax */
c_value_print, /* FIXME */
{"", "", "", ""}, /* Binary format info */
{"0%o", "0", "o", ""}, /* Octal format info */
{"%d", "", "d", ""}, /* Decimal format info */
{"0x%x", "0x", "x", ""}, /* Hex format info */
f_op_print_tab, /* expression operators for printing */
LANG_MAGIC
};
void
_initialize_f_language ()
{
builtin_type_f_void =
init_type (TYPE_CODE_VOID, 1,
0,
"VOID", (struct objfile *) NULL);
builtin_type_f_character =
init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
0,
"character", (struct objfile *) NULL);
builtin_type_f_logical_s1 =
init_type (TYPE_CODE_BOOL, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED,
"logical*1", (struct objfile *) NULL);
builtin_type_f_integer_s2 =
init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
0,
"integer*2", (struct objfile *) NULL);
builtin_type_f_logical_s2 =
init_type (TYPE_CODE_BOOL, TARGET_SHORT_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED,
"logical*2", (struct objfile *) NULL);
builtin_type_f_integer =
init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT,
0,
"integer", (struct objfile *) NULL);
builtin_type_f_logical =
init_type (TYPE_CODE_BOOL, TARGET_INT_BIT / TARGET_CHAR_BIT,
TYPE_FLAG_UNSIGNED,
"logical*4", (struct objfile *) NULL);
builtin_type_f_real =
init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT,
0,
"real", (struct objfile *) NULL);
builtin_type_f_real_s8 =
init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT,
0,
"real*8", (struct objfile *) NULL);
builtin_type_f_real_s16 =
init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT,
0,
"real*16", (struct objfile *) NULL);
builtin_type_f_complex_s8 =
init_type (TYPE_CODE_COMPLEX, TARGET_COMPLEX_BIT / TARGET_CHAR_BIT,
0,
"complex*8", (struct objfile *) NULL);
builtin_type_f_complex_s16 =
init_type (TYPE_CODE_COMPLEX, TARGET_DOUBLE_COMPLEX_BIT / TARGET_CHAR_BIT,
0,
"complex*16", (struct objfile *) NULL);
#if 0
/* We have a new size == 4 double floats for the
complex*32 data type */
builtin_type_f_complex_s32 =
init_type (TYPE_CODE_COMPLEX, TARGET_EXT_COMPLEX_BIT / TARGET_CHAR_BIT,
0,
"complex*32", (struct objfile *) NULL);
#endif
builtin_type_string =
init_type (TYPE_CODE_STRING, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
0,
"character string", (struct objfile *) NULL);
add_language (&f_language_defn);
}
/* Following is dubious stuff that had been in the xcoff reader. */
struct saved_fcn
{
long line_offset; /* Line offset for function */
struct saved_fcn *next;
};
struct saved_bf_symnum
{
long symnum_fcn; /* Symnum of function (i.e. .function directive) */
long symnum_bf; /* Symnum of .bf for this function */
struct saved_bf_symnum *next;
};
typedef struct saved_fcn SAVED_FUNCTION, *SAVED_FUNCTION_PTR;
typedef struct saved_bf_symnum SAVED_BF, *SAVED_BF_PTR;
SAVED_BF_PTR allocate_saved_bf_node()
{
SAVED_BF_PTR new;
new = (SAVED_BF_PTR) malloc (sizeof (SAVED_BF));
if (new == NULL)
fatal("could not allocate enough memory to save one more .bf on save list");
return(new);
}
SAVED_FUNCTION *allocate_saved_function_node()
{
SAVED_FUNCTION *new;
new = (SAVED_FUNCTION *) malloc (sizeof (SAVED_FUNCTION));
if (new == NULL)
fatal("could not allocate enough memory to save one more function on save list");
return(new);
}
SAVED_F77_COMMON_PTR allocate_saved_f77_common_node()
{
SAVED_F77_COMMON_PTR new;
new = (SAVED_F77_COMMON_PTR) malloc (sizeof (SAVED_F77_COMMON));
if (new == NULL)
fatal("could not allocate enough memory to save one more F77 COMMON blk on save list");
return(new);
}
COMMON_ENTRY_PTR allocate_common_entry_node()
{
COMMON_ENTRY_PTR new;
new = (COMMON_ENTRY_PTR) malloc (sizeof (COMMON_ENTRY));
if (new == NULL)
fatal("could not allocate enough memory to save one more COMMON entry on save list");
return(new);
}
SAVED_F77_COMMON_PTR head_common_list=NULL; /* Ptr to 1st saved COMMON */
SAVED_F77_COMMON_PTR tail_common_list=NULL; /* Ptr to last saved COMMON */
SAVED_F77_COMMON_PTR current_common=NULL; /* Ptr to current COMMON */
static SAVED_BF_PTR saved_bf_list=NULL; /* Ptr to (.bf,function)
list*/
static SAVED_BF_PTR saved_bf_list_end=NULL; /* Ptr to above list's end */
static SAVED_BF_PTR current_head_bf_list=NULL; /* Current head of above list
*/
static SAVED_BF_PTR tmp_bf_ptr; /* Generic temporary for use
in macros */
/* The following function simply enters a given common block onto
the global common block chain */
void add_common_block(name,offset,secnum,func_stab)
char *name;
CORE_ADDR offset;
int secnum;
char *func_stab;
{
SAVED_F77_COMMON_PTR tmp;
char *c,*local_copy_func_stab;
/* If the COMMON block we are trying to add has a blank
name (i.e. "#BLNK_COM") then we set it to __BLANK
because the darn "#" character makes GDB's input
parser have fits. */
if (STREQ(name,BLANK_COMMON_NAME_ORIGINAL) ||
STREQ(name,BLANK_COMMON_NAME_MF77))
{
free(name);
name = alloca(strlen(BLANK_COMMON_NAME_LOCAL) + 1);
strcpy(name,BLANK_COMMON_NAME_LOCAL);
}
tmp = allocate_saved_f77_common_node();
local_copy_func_stab = malloc (strlen(func_stab) + 1);
strcpy(local_copy_func_stab,func_stab);
tmp->name = malloc(strlen(name) + 1);
/* local_copy_func_stab is a stabstring, let us first extract the
function name from the stab by NULLing out the ':' character. */
c = NULL;
c = strchr(local_copy_func_stab,':');
if (c)
*c = '\0';
else
error("Malformed function STAB found in add_common_block()");
tmp->owning_function = malloc (strlen(local_copy_func_stab) + 1);
strcpy(tmp->owning_function,local_copy_func_stab);
strcpy(tmp->name,name);
tmp->offset = offset;
tmp->next = NULL;
tmp->entries = NULL;
tmp->secnum = secnum;
current_common = tmp;
if (head_common_list == NULL)
{
head_common_list = tail_common_list = tmp;
}
else
{
tail_common_list->next = tmp;
tail_common_list = tmp;
}
}
/* The following function simply enters a given common entry onto
the "current_common" block that has been saved away. */
void add_common_entry(entry_sym_ptr)
struct symbol *entry_sym_ptr;
{
COMMON_ENTRY_PTR tmp;
/* The order of this list is important, since
we expect the entries to appear in decl.
order when we later issue "info common" calls */
tmp = allocate_common_entry_node();
tmp->next = NULL;
tmp->symbol = entry_sym_ptr;
if (current_common == NULL)
error("Attempt to add COMMON entry with no block open!");
else
{
if (current_common->entries == NULL)
{
current_common->entries = tmp;
current_common->end_of_entries = tmp;
}
else
{
current_common->end_of_entries->next = tmp;
current_common->end_of_entries = tmp;
}
}
}
/* This routine finds the first encountred COMMON block named "name" */
SAVED_F77_COMMON_PTR find_first_common_named(name)
char *name;
{
SAVED_F77_COMMON_PTR tmp;
tmp = head_common_list;
while (tmp != NULL)
{
if (STREQ(tmp->name,name))
return(tmp);
else
tmp = tmp->next;
}
return(NULL);
}
/* This routine finds the first encountred COMMON block named "name"
that belongs to function funcname */
SAVED_F77_COMMON_PTR find_common_for_function(name, funcname)
char *name;
char *funcname;
{
SAVED_F77_COMMON_PTR tmp;
tmp = head_common_list;
while (tmp != NULL)
{
if (STREQ(tmp->name,name) && STREQ(tmp->owning_function,funcname))
return(tmp);
else
tmp = tmp->next;
}
return(NULL);
}
/* The following function is called to patch up the offsets
for the statics contained in the COMMON block named
"name." */
void patch_common_entries (blk, offset, secnum)
SAVED_F77_COMMON_PTR blk;
CORE_ADDR offset;
int secnum;
{
COMMON_ENTRY_PTR entry;
blk->offset = offset; /* Keep this around for future use. */
entry = blk->entries;
while (entry != NULL)
{
SYMBOL_VALUE (entry->symbol) += offset;
SYMBOL_SECTION (entry->symbol) = secnum;
entry = entry->next;
}
blk->secnum = secnum;
}
/* Patch all commons named "name" that need patching.Since COMMON
blocks occur with relative infrequency, we simply do a linear scan on
the name. Eventually, the best way to do this will be a
hashed-lookup. Secnum is the section number for the .bss section
(which is where common data lives). */
void patch_all_commons_by_name (name, offset, secnum)
char *name;
CORE_ADDR offset;
int secnum;
{
SAVED_F77_COMMON_PTR tmp;
/* For blank common blocks, change the canonical reprsentation
of a blank name */
if ((STREQ(name,BLANK_COMMON_NAME_ORIGINAL)) ||
(STREQ(name,BLANK_COMMON_NAME_MF77)))
{
free(name);
name = alloca(strlen(BLANK_COMMON_NAME_LOCAL) + 1);
strcpy(name,BLANK_COMMON_NAME_LOCAL);
}
tmp = head_common_list;
while (tmp != NULL)
{
if (COMMON_NEEDS_PATCHING(tmp))
if (STREQ(tmp->name,name))
patch_common_entries(tmp,offset,secnum);
tmp = tmp->next;
}
}
/* This macro adds the symbol-number for the start of the function
(the symbol number of the .bf) referenced by symnum_fcn to a
list. This list, in reality should be a FIFO queue but since
#line pragmas sometimes cause line ranges to get messed up
we simply create a linear list. This list can then be searched
first by a queueing algorithm and upon failure fall back to
a linear scan. */
#define ADD_BF_SYMNUM(bf_sym,fcn_sym) \
\
if (saved_bf_list == NULL) \
{ \
tmp_bf_ptr = allocate_saved_bf_node(); \
\
tmp_bf_ptr->symnum_bf = (bf_sym); \
tmp_bf_ptr->symnum_fcn = (fcn_sym); \
tmp_bf_ptr->next = NULL; \
\
current_head_bf_list = saved_bf_list = tmp_bf_ptr; \
saved_bf_list_end = tmp_bf_ptr; \
} \
else \
{ \
tmp_bf_ptr = allocate_saved_bf_node(); \
\
tmp_bf_ptr->symnum_bf = (bf_sym); \
tmp_bf_ptr->symnum_fcn = (fcn_sym); \
tmp_bf_ptr->next = NULL; \
\
saved_bf_list_end->next = tmp_bf_ptr; \
saved_bf_list_end = tmp_bf_ptr; \
}
/* This function frees the entire (.bf,function) list */
void
clear_bf_list()
{
SAVED_BF_PTR tmp = saved_bf_list;
SAVED_BF_PTR next = NULL;
while (tmp != NULL)
{
next = tmp->next;
free(tmp);
tmp=next;
}
saved_bf_list = NULL;
}
int global_remote_debug;
long
get_bf_for_fcn (the_function)
long the_function;
{
SAVED_BF_PTR tmp;
int nprobes = 0;
long retval = 0;
/* First use a simple queuing algorithm (i.e. look and see if the
item at the head of the queue is the one you want) */
if (saved_bf_list == NULL)
fatal ("cannot get .bf node off empty list");
if (current_head_bf_list != NULL)
if (current_head_bf_list->symnum_fcn == the_function)
{
if (global_remote_debug)
fprintf(stderr,"*");
tmp = current_head_bf_list;
current_head_bf_list = current_head_bf_list->next;
return(tmp->symnum_bf);
}
/* If the above did not work (probably because #line directives were
used in the sourcefile and they messed up our internal tables) we now do
the ugly linear scan */
if (global_remote_debug)
fprintf(stderr,"\ndefaulting to linear scan\n");
nprobes = 0;
tmp = saved_bf_list;
while (tmp != NULL)
{
nprobes++;
if (tmp->symnum_fcn == the_function)
{
if (global_remote_debug)
fprintf(stderr,"Found in %d probes\n",nprobes);
current_head_bf_list = tmp->next;
return(tmp->symnum_bf);
}
tmp= tmp->next;
}
return(-1);
}
static SAVED_FUNCTION_PTR saved_function_list=NULL;
static SAVED_FUNCTION_PTR saved_function_list_end=NULL;
void clear_function_list()
{
SAVED_FUNCTION_PTR tmp = saved_function_list;
SAVED_FUNCTION_PTR next = NULL;
while (tmp != NULL)
{
next = tmp->next;
free(tmp);
tmp = next;
}
saved_function_list = NULL;
}

90
gdb/f-lang.h Normal file
View file

@ -0,0 +1,90 @@
/* Fortran language support definitions for GDB, the GNU debugger.
Copyright 1992, 1993, 1994 Free Software Foundation, Inc.
Contributed by Motorola. Adapted from the C definitions by Farooq Butt
(fmbutt@engage.sps.mot.com).
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., 675 Mass Ave, Cambridge, MA 02139, USA. */
extern int f_parse PARAMS ((void));
extern void f_error PARAMS ((char *)); /* Defined in f-exp.y */
extern void f_print_type PARAMS ((struct type *, char *, FILE *, int, int));
extern int f_val_print PARAMS ((struct type *, char *, CORE_ADDR, FILE *,
int, int, int, enum val_prettyprint));
/* Language-specific data structures */
struct common_entry
{
struct symbol *symbol; /* The symbol node corresponding
to this component */
struct common_entry *next; /* The next component */
};
struct saved_f77_common
{
char *name; /* Name of COMMON */
char *owning_function; /* Name of parent function */
int secnum; /* Section # of .bss */
CORE_ADDR offset; /* Offset from .bss for
this block */
struct common_entry *entries; /* List of block's components */
struct common_entry *end_of_entries; /* ptr. to end of components */
struct saved_f77_common *next; /* Next saved COMMON block */
};
typedef struct saved_f77_common SAVED_F77_COMMON, *SAVED_F77_COMMON_PTR;
typedef struct common_entry COMMON_ENTRY, *COMMON_ENTRY_PTR;
extern SAVED_F77_COMMON_PTR head_common_list; /* Ptr to 1st saved COMMON */
extern SAVED_F77_COMMON_PTR tail_common_list; /* Ptr to last saved COMMON */
extern SAVED_F77_COMMON_PTR current_common; /* Ptr to current COMMON */
#define UNINITIALIZED_SECNUM -1
#define COMMON_NEEDS_PATCHING(blk) ((blk)->secnum == UNINITIALIZED_SECNUM)
#define BLANK_COMMON_NAME_ORIGINAL "#BLNK_COM" /* XLF assigned */
#define BLANK_COMMON_NAME_MF77 "__BLNK__" /* MF77 assigned */
#define BLANK_COMMON_NAME_LOCAL "__BLANK" /* Local GDB */
#define BOUND_FETCH_OK 1
#define BOUND_FETCH_ERROR -999
/* When reasonable array bounds cannot be fetched, such as when
you ask to 'mt print symbols' and there is no stack frame and
therefore no way of knowing the bounds of stack-based arrays,
we have to assign default bounds, these are as good as any... */
#define DEFAULT_UPPER_BOUND 999999
#define DEFAULT_LOWER_BOUND -999999
extern char *real_main_name; /* Name of main function */
extern int real_main_c_value; /* C_value field of main function */
extern int f77_get_dynamic_upperbound PARAMS ((struct type *, int *));
extern int f77_get_dynamic_lowerbound PARAMS ((struct type *, int *));
extern void f77_get_dynamic_array_length PARAMS ((struct type *));
#define DEFAULT_DOTMAIN_NAME_IN_MF77 ".MAIN_"
#define DEFAULT_MAIN_NAME_IN_MF77 "MAIN_"
#define DEFAULT_DOTMAIN_NAME_IN_XLF_BUGGY ".main "
#define DEFAULT_DOTMAIN_NAME_IN_XLF ".main"

457
gdb/f-typeprint.c Normal file
View file

@ -0,0 +1,457 @@
/* Support for printing Fortran types for GDB, the GNU debugger.
Copyright 1986, 1988, 1989, 1991 Free Software Foundation, Inc.
Contributed by Motorola. Adapted from the C version by Farooq Butt
(fmbutt@engage.sps.mot.com).
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., 675 Mass Ave, Cambridge, MA 02139, USA. */
#include "defs.h"
#include "obstack.h"
#include "bfd.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "value.h"
#include "gdbcore.h"
#include "target.h"
#include "command.h"
#include "gdbcmd.h"
#include "language.h"
#include "demangle.h"
#include "f-lang.h"
#include "typeprint.h"
#include "frame.h" /* ??? */
#include <string.h>
#include <errno.h>
static void f_type_print_args PARAMS ((struct type *, FILE *));
static void f_type_print_varspec_suffix PARAMS ((struct type *, FILE *,
int, int, int));
void f_type_print_varspec_prefix PARAMS ((struct type *, FILE *, int, int));
void f_type_print_base PARAMS ((struct type *, FILE *, int, int));
/* LEVEL is the depth to indent lines by. */
void
f_print_type (type, varstring, stream, show, level)
struct type *type;
char *varstring;
FILE *stream;
int show;
int level;
{
register enum type_code code;
int demangled_args;
f_type_print_base (type, stream, show, level);
code = TYPE_CODE (type);
if ((varstring != NULL && *varstring != '\0')
||
/* Need a space if going to print stars or brackets;
but not if we will print just a type name. */
((show > 0 || TYPE_NAME (type) == 0)
&&
(code == TYPE_CODE_PTR || code == TYPE_CODE_FUNC
|| code == TYPE_CODE_METHOD
|| code == TYPE_CODE_ARRAY
|| code == TYPE_CODE_MEMBER
|| code == TYPE_CODE_REF)))
fputs_filtered (" ", stream);
f_type_print_varspec_prefix (type, stream, show, 0);
fputs_filtered (varstring, stream);
/* For demangled function names, we have the arglist as part of the name,
so don't print an additional pair of ()'s */
demangled_args = varstring[strlen(varstring) - 1] == ')';
f_type_print_varspec_suffix (type, stream, show, 0, demangled_args);
}
/* Print any asterisks or open-parentheses needed before the
variable name (to describe its type).
On outermost call, pass 0 for PASSED_A_PTR.
On outermost call, SHOW > 0 means should ignore
any typename for TYPE and show its details.
SHOW is always zero on recursive calls. */
void
f_type_print_varspec_prefix (type, stream, show, passed_a_ptr)
struct type *type;
FILE *stream;
int show;
int passed_a_ptr;
{
char *name;
if (type == 0)
return;
if (TYPE_NAME (type) && show <= 0)
return;
QUIT;
switch (TYPE_CODE (type))
{
case TYPE_CODE_PTR:
f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 1);
break;
case TYPE_CODE_FUNC:
f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
if (passed_a_ptr)
fprintf_filtered (stream, "(");
break;
case TYPE_CODE_ARRAY:
f_type_print_varspec_prefix (TYPE_TARGET_TYPE (type), stream, 0, 0);
break;
case TYPE_CODE_UNDEF:
case TYPE_CODE_STRUCT:
case TYPE_CODE_UNION:
case TYPE_CODE_ENUM:
case TYPE_CODE_INT:
case TYPE_CODE_FLT:
case TYPE_CODE_VOID:
case TYPE_CODE_ERROR:
case TYPE_CODE_CHAR:
case TYPE_CODE_BOOL:
case TYPE_CODE_SET:
case TYPE_CODE_RANGE:
case TYPE_CODE_STRING:
/* These types need no prefix. They are listed here so that
gcc -Wall will reveal any types that haven't been handled. */
break;
}
}
static void
f_type_print_args (type, stream)
struct type *type;
FILE *stream;
{
int i;
struct type **args;
fprintf_filtered (stream, "(");
args = TYPE_ARG_TYPES (type);
if (args != NULL)
{
if (args[1] == NULL)
{
fprintf_filtered (stream, "...");
}
else
{
for (i = 1; args[i] != NULL && args[i]->code != TYPE_CODE_VOID; i++)
{
f_print_type (args[i], "", stream, -1, 0);
if (args[i+1] == NULL)
fprintf_filtered (stream, "...");
else if (args[i+1]->code != TYPE_CODE_VOID)
{
fprintf_filtered (stream, ",");
wrap_here (" ");
}
}
}
}
fprintf_filtered (stream, ")");
}
/* Print any array sizes, function arguments or close parentheses
needed after the variable name (to describe its type).
Args work like c_type_print_varspec_prefix. */
static void
f_type_print_varspec_suffix (type, stream, show, passed_a_ptr, demangled_args)
struct type *type;
FILE *stream;
int show;
int passed_a_ptr;
int demangled_args;
{
CORE_ADDR current_frame_addr = 0;
int upper_bound,lower_bound;
int lower_bound_was_default = 0;
static int arrayprint_recurse_level = 0;
int retcode;
if (type == 0)
return;
if (TYPE_NAME (type) && show <= 0)
return;
QUIT;
switch (TYPE_CODE (type))
{
case TYPE_CODE_ARRAY:
arrayprint_recurse_level++;
if (arrayprint_recurse_level == 1)
fprintf_filtered(stream,"(");
else
fprintf_filtered(stream,",");
retcode = f77_get_dynamic_lowerbound (type,&lower_bound);
lower_bound_was_default = 0;
if (retcode == BOUND_FETCH_ERROR)
fprintf_filtered (stream,"???");
else
if (lower_bound == 1) /* The default */
lower_bound_was_default = 1;
else
fprintf_filtered (stream,"%d",lower_bound);
if (lower_bound_was_default)
lower_bound_was_default = 0;
else
fprintf_filtered(stream,":");
/* Make sure that, if we have an assumed size array, we
print out a warning and print the upperbound as '*' */
if (TYPE_ARRAY_UPPER_BOUND_TYPE(type) == BOUND_CANNOT_BE_DETERMINED)
fprintf_filtered (stream, "*");
else
{
retcode = f77_get_dynamic_upperbound(type,&upper_bound);
if (retcode == BOUND_FETCH_ERROR)
fprintf_filtered(stream,"???");
else
fprintf_filtered(stream,"%d",upper_bound);
}
f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 0, 0);
if (arrayprint_recurse_level == 1)
fprintf_filtered (stream, ")");
arrayprint_recurse_level--;
break;
case TYPE_CODE_PTR:
case TYPE_CODE_REF:
f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0, 1, 0);
fprintf_filtered(stream,")");
break;
case TYPE_CODE_FUNC:
f_type_print_varspec_suffix (TYPE_TARGET_TYPE (type), stream, 0,
passed_a_ptr, 0);
if (passed_a_ptr)
fprintf_filtered (stream, ")");
fprintf_filtered (stream, "()");
break;
case TYPE_CODE_UNDEF:
case TYPE_CODE_STRUCT:
case TYPE_CODE_UNION:
case TYPE_CODE_ENUM:
case TYPE_CODE_INT:
case TYPE_CODE_FLT:
case TYPE_CODE_VOID:
case TYPE_CODE_ERROR:
case TYPE_CODE_CHAR:
case TYPE_CODE_BOOL:
case TYPE_CODE_SET:
case TYPE_CODE_RANGE:
case TYPE_CODE_LITERAL_STRING:
case TYPE_CODE_STRING:
/* These types do not need a suffix. They are listed so that
gcc -Wall will report types that may not have been considered. */
break;
}
}
void
print_equivalent_f77_float_type (type, stream)
struct type *type;
FILE *stream;
{
/* Override type name "float" and make it the
appropriate real. XLC stupidly outputs -12 as a type
for real when it really should be outputting -18 */
switch (TYPE_LENGTH (type))
{
case 4:
fprintf_filtered (stream, "real*4");
break;
case 8:
fprintf_filtered(stream,"real*8");
break;
}
}
/* Print the name of the type (or the ultimate pointer target,
function value or array element), or the description of a
structure or union.
SHOW nonzero means don't print this type as just its name;
show its real definition even if it has a name.
SHOW zero means print just typename or struct tag if there is one
SHOW negative means abbreviate structure elements.
SHOW is decremented for printing of structure elements.
LEVEL is the depth to indent by.
We increase it for some recursive calls. */
void
f_type_print_base (type, stream, show, level)
struct type *type;
FILE *stream;
int show;
int level;
{
char *name;
register int i;
register int len;
register int lastval;
char *mangled_name;
char *demangled_name;
enum {s_none, s_public, s_private, s_protected} section_type;
int retcode,upper_bound;
QUIT;
wrap_here (" ");
if (type == NULL)
{
fputs_filtered ("<type unknown>", stream);
return;
}
/* When SHOW is zero or less, and there is a valid type name, then always
just print the type name directly from the type. */
if ((show <= 0) && (TYPE_NAME (type) != NULL))
{
/* Damn builtin types on RS6000! They call a float "float"
so we gotta translate to appropriate F77'isms */
if (TYPE_CODE (type) == TYPE_CODE_FLT)
print_equivalent_f77_float_type (type, stream);
else
fputs_filtered (TYPE_NAME (type), stream);
return;
}
switch (TYPE_CODE (type))
{
case TYPE_CODE_ARRAY:
f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
break;
case TYPE_CODE_FUNC:
f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
break;
case TYPE_CODE_PTR:
fprintf_filtered (stream, "PTR TO -> ( ");
f_type_print_base (TYPE_TARGET_TYPE (type), stream, show, level);
break;
case TYPE_CODE_VOID:
fprintf_filtered (stream, "VOID");
break;
case TYPE_CODE_UNDEF:
fprintf_filtered (stream, "struct <unknown>");
break;
case TYPE_CODE_ERROR:
fprintf_filtered (stream, "<unknown type>");
break;
case TYPE_CODE_RANGE:
/* This should not occur */
fprintf_filtered (stream, "<range type>");
break;
case TYPE_CODE_CHAR:
/* Override name "char" and make it "character" */
fprintf_filtered (stream, "character");
break;
case TYPE_CODE_INT:
/* There may be some character types that attempt to come
through as TYPE_CODE_INT since dbxstclass.h is so
C-oriented, we must change these to "character" from "char". */
if (STREQ(TYPE_NAME(type),"char"))
fprintf_filtered (stream,"character");
else
goto default_case;
break;
case TYPE_CODE_COMPLEX:
case TYPE_CODE_LITERAL_COMPLEX:
fprintf_filtered (stream,"complex*");
fprintf_filtered (stream,"%d",TYPE_LENGTH(type));
break;
case TYPE_CODE_FLT:
print_equivalent_f77_float_type(type,stream);
break;
case TYPE_CODE_LITERAL_STRING:
fprintf_filtered (stream, "character*%d",
TYPE_ARRAY_UPPER_BOUND_VALUE (type));
break;
case TYPE_CODE_STRING:
/* Strings may have dynamic upperbounds (lengths) like arrays */
if (TYPE_ARRAY_UPPER_BOUND_TYPE (type) == BOUND_CANNOT_BE_DETERMINED)
fprintf_filtered("character*(*)");
else
{
retcode = f77_get_dynamic_upperbound(type,&upper_bound);
if (retcode == BOUND_FETCH_ERROR)
fprintf_filtered(stream,"character*???");
else
fprintf_filtered(stream,"character*%d",upper_bound);
}
break;
default_case:
default:
/* Handle types not explicitly handled by the other cases,
such as fundamental types. For these, just print whatever
the type name is, as recorded in the type itself. If there
is no type name, then complain. */
if (TYPE_NAME (type) != NULL)
fputs_filtered (TYPE_NAME (type), stream);
else
error ("Invalid type code (%d) in symbol table.", TYPE_CODE (type));
break;
}
}

889
gdb/f-valprint.c Normal file
View file

@ -0,0 +1,889 @@
/* Support for printing Fortran values for GDB, the GNU debugger.
Copyright 1993, 1994 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., 675 Mass Ave, Cambridge, MA 02139, USA. */
#include "defs.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"
extern struct obstack dont_print_obstack;
extern unsigned int print_max; /* No of array elements to print */
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);
}
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);
}
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 */
void
f77_get_dynamic_length_of_aggregate (type)
struct type *type;
{
int upper_bound = -1;
int lower_bound = 1;
unsigned int current_total = 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 (TYPE_TARGET_TYPE (type));
}
/* Print a FORTRAN COMPLEX value of type TYPE, pointed to in GDB by VALADDR,
on STREAM. which_complex indicates precision, which may be regular,
*16, or *32 */
void
f77_print_cmplx (valaddr, type, stream, which_complex)
char *valaddr;
struct type *type;
FILE *stream;
int which_complex;
{
float *f1,*f2;
double *d1, *d2;
int i;
switch (which_complex)
{
case TARGET_COMPLEX_BIT:
f1 = (float *) valaddr;
f2 = (float *) (valaddr + sizeof(float));
fprintf_filtered (stream, "(%.7e,%.7e)", *f1, *f2);
break;
case TARGET_DOUBLE_COMPLEX_BIT:
d1 = (double *) valaddr;
d2 = (double *) (valaddr + sizeof(double));
fprintf_filtered (stream, "(%.16e,%.16e)", *d1, *d2);
break;
#if 0
case TARGET_EXT_COMPLEX_BIT:
fprintf_filtered (stream, "<complex*32 format unavailable, "
"printing raw data>\n");
fprintf_filtered (stream, "( [ ");
for (i = 0;i<4;i++)
fprintf_filtered (stream, "0x%x ",
* ( (unsigned int *) valaddr+i));
fprintf_filtered (stream, "],\n [ ");
for (i=4;i<8;i++)
fprintf_filtered (stream, "0x%x ",
* ((unsigned int *) valaddr+i));
fprintf_filtered (stream, "] )");
break;
#endif
default:
fprintf_filtered (stream, "<cannot handle complex of this type>");
break;
}
}
/* Function that sets up the array offset,size table for the array
type "type". */
void
f77_create_arrayprint_offset_tbl (type, stream)
struct type *type;
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;
if (ndimen == 1)
F77_DIM_OFFSET (ndimen) = 1;
else
F77_DIM_OFFSET (ndimen) =
F77_DIM_OFFSET (ndimen - 1) * F77_DIM_SIZE(ndimen - 1);
tmp_type = TYPE_TARGET_TYPE (tmp_type);
ndimen++;
}
eltlen = TYPE_LENGTH (tmp_type);
/* 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 */
tmp_type = type;
ndimen = 1;
while ((TYPE_CODE (tmp_type) == TYPE_CODE_ARRAY))
{
F77_DIM_OFFSET (ndimen) *= eltlen;
ndimen++;
tmp_type = TYPE_TARGET_TYPE (tmp_type);
}
}
/* Actual function which prints out F77 arrays, Valaddr == address in
the superior. Address == the address in the inferior. */
void
f77_print_array_1 (nss, ndimensions, type, valaddr, address,
stream, format, deref_ref, recurse, pretty)
int nss;
int ndimensions;
char *valaddr;
struct type *type;
CORE_ADDR address;
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, i);
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),
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() */
void
f77_print_array (type, valaddr, address, stream, format, deref_ref, recurse,
pretty)
struct type *type;
char *valaddr;
CORE_ADDR address;
FILE *stream;
int format;
int deref_ref;
int recurse;
enum val_prettyprint pretty;
{
int array_size_array[MAX_FORTRAN_DIMS+1];
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, address, stream, format, deref_ref, recurse,
pretty)
struct type *type;
char *valaddr;
CORE_ADDR address;
FILE *stream;
int format;
int deref_ref;
int recurse;
enum val_prettyprint pretty;
{
register unsigned int i = 0; /* Number of characters printed */
unsigned len;
struct type *elttype;
unsigned eltlen;
LONGEST val;
struct internalvar *ivar;
char *localstr;
unsigned char c;
CORE_ADDR addr;
switch (TYPE_CODE (type))
{
case TYPE_CODE_LITERAL_STRING:
/* It is trivial to print out F77 strings allocated in the
superior process. The address field is actually a
pointer to the bytes of the literal. For an internalvar,
valaddr points to a ptr. which points to
VALUE_LITERAL_DATA(value->internalvar->value)
and for straight literals (i.e. of the form 'hello world'),
valaddr points a ptr to VALUE_LITERAL_DATA(value). */
/* First deref. valaddr */
addr = * (CORE_ADDR *) valaddr;
if (addr)
{
len = TYPE_LENGTH (type);
localstr = alloca (len + 1);
strncpy (localstr, addr, len);
localstr[len] = '\0';
fprintf_filtered (stream, "'%s'", localstr);
}
else
fprintf_filtered (stream, "Unable to print literal F77 string");
break;
/* Strings are a little bit funny. They can be viewed as
monolithic arrays that are dealt with as atomic data
items. As such they are the only atomic data items whose
contents are not located in the superior process. Instead
instead of having the actual data, they contain pointers
to addresses in the inferior where data is located. Thus
instead of using valaddr, we use address. */
case TYPE_CODE_STRING:
f77_get_dynamic_length_of_aggregate (type);
val_print_string (address, TYPE_LENGTH (type), stream);
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 = 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, 0, 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, 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_LITERAL_COMPLEX:
/* We know that the literal complex is stored in the superior
process not the inferior and that it is 16 bytes long.
Just like the case above with a literal array, the
bytes for the the literal complex number are stored
at the address pointed to by valaddr */
if (TYPE_LENGTH(type) == 32)
error("Cannot currently print out complex*32 literals");
/* First deref. valaddr */
addr = * (CORE_ADDR *) valaddr;
if (addr)
{
fprintf_filtered (stream, "(");
if (TYPE_LENGTH(type) == 16)
{
fprintf_filtered (stream, "%.16f", * (double *) addr);
fprintf_filtered (stream, ", %.16f", * (double *)
(addr + sizeof(double)));
}
else
{
fprintf_filtered (stream, "%.8f", * (float *) addr);
fprintf_filtered (stream, ", %.8f", * (float *)
(addr + sizeof(float)));
}
fprintf_filtered (stream, ") ");
}
else
fprintf_filtered (stream, "Unable to print literal F77 array");
break;
case TYPE_CODE_COMPLEX:
switch (TYPE_LENGTH (type))
{
case 8:
f77_print_cmplx (valaddr, type, stream, TARGET_COMPLEX_BIT);
break;
case 16:
f77_print_cmplx(valaddr, type, stream, TARGET_DOUBLE_COMPLEX_BIT);
break;
#if 0
case 32:
f77_print_cmplx(valaddr, type, stream, TARGET_EXT_COMPLEX_BIT);
break;
#endif
default:
error ("Cannot print out complex*%d variables", TYPE_LENGTH(type));
}
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));
}
fflush (stream);
return 0;
}
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;
char *cmd;
/* 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 comnname is NULL, we assume the user wishes to see the
which COMMON blocks are visible here and then return */
if (strlen (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,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'. */
int
there_is_a_visible_common_named (comname)
char *comname;
{
SAVED_F77_COMMON_PTR the_common;
COMMON_ENTRY_PTR entry;
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);
}
void
_initialize_f_valprint ()
{
add_info ("common", info_common_command,
"Print out the values contained in a Fortran COMMON block.");
}

80
gdb/gdbtypes.c
View file

@ -487,6 +487,86 @@ create_set_type (result_type, domain_type)
return (result_type);
}
/* Create an F77 literal complex type composed of the two types we are
given as arguments. */
struct type *
f77_create_literal_complex_type (type_arg1, type_arg2)
struct type *type_arg1;
struct type *type_arg2;
{
struct type *result;
/* First make sure that the 2 components of the complex
number both have the same type */
if (TYPE_CODE (type_arg1) != TYPE_CODE (type_arg2))
error ("Both components of a F77 complex number must have the same type!");
result = alloc_type (TYPE_OBJFILE (type_arg1));
TYPE_CODE (result) = TYPE_CODE_LITERAL_COMPLEX;
TYPE_LENGTH (result) = TYPE_LENGTH(type_arg1) * 2;
return result;
}
/* Create a F77 LITERAL string type supplied by the user from the keyboard.
Elements will be of type ELEMENT_TYPE, the indices will be of type
RANGE_TYPE.
FIXME: Maybe we should check the TYPE_CODE of RESULT_TYPE to make
sure it is TYPE_CODE_UNDEF before we bash it into an array type?
This is a total clone of create_array_type() except that there are
a few simplyfing assumptions (e.g all bound types are simple). */
struct type *
f77_create_literal_string_type (result_type, range_type)
struct type *result_type;
struct type *range_type;
{
int low_bound;
int high_bound;
if (TYPE_CODE (range_type) != TYPE_CODE_RANGE)
{
/* FIXME: We only handle range types at the moment. Complain and
create a dummy range type to use. */
warning ("internal error: array index type must be a range type");
range_type = lookup_fundamental_type (TYPE_OBJFILE (range_type),
FT_INTEGER);
range_type = create_range_type ((struct type *) NULL, range_type, 0, 0);
}
if (result_type == NULL)
result_type = alloc_type (TYPE_OBJFILE (range_type));
TYPE_CODE (result_type) = TYPE_CODE_LITERAL_STRING;
TYPE_TARGET_TYPE (result_type) = builtin_type_f_character;
low_bound = TYPE_FIELD_BITPOS (range_type, 0);
high_bound = TYPE_FIELD_BITPOS (range_type, 1);
/* Safely can assume that all bound types are simple */
TYPE_LENGTH (result_type) =
TYPE_LENGTH (builtin_type_f_character) * (high_bound - low_bound + 1);
TYPE_NFIELDS (result_type) = 1;
TYPE_FIELDS (result_type) =
(struct field *) TYPE_ALLOC (result_type, sizeof (struct field));
memset (TYPE_FIELDS (result_type), 0, sizeof (struct field));
TYPE_FIELD_TYPE (result_type, 0) = range_type;
TYPE_VPTR_FIELDNO (result_type) = -1;
/* Remember that all literal strings in F77 are of the
character*N type. */
TYPE_ARRAY_LOWER_BOUND_TYPE (result_type) = BOUND_SIMPLE;
TYPE_ARRAY_UPPER_BOUND_TYPE (result_type) = BOUND_SIMPLE;
return result_type;
}
/* Smash TYPE to be a type of members of DOMAIN with type TO_TYPE.
A MEMBER is a wierd thing -- it amounts to a typed offset into
a struct, e.g. "an int at offset 8". A MEMBER TYPE doesn't

50
gdb/gdbtypes.h
View file

@ -80,9 +80,7 @@ enum type_code
TYPE_CODE_FUNC, /* Function type */
TYPE_CODE_INT, /* Integer type */
/* Floating type. This is *NOT* a complex type. Complex types, when
we have them, will have their own type code (or TYPE_CODE_ERROR if
we can parse a complex type but not manipulate it). There are parts
/* Floating type. This is *NOT* a complex type. Beware, there are parts
of GDB which bogusly assume that TYPE_CODE_FLT can mean complex. */
TYPE_CODE_FLT,
@ -119,7 +117,12 @@ enum type_code
/* Boolean type. 0 is false, 1 is true, and other values are non-boolean
(e.g. FORTRAN "logical" used as unsigned int). */
TYPE_CODE_BOOL
TYPE_CODE_BOOL,
/* Fortran */
TYPE_CODE_COMPLEX, /* Complex float */
TYPE_CODE_LITERAL_COMPLEX, /* */
TYPE_CODE_LITERAL_STRING /* */
};
/* For now allow source to use TYPE_CODE_CLASS for C++ classes, as an
@ -182,6 +185,17 @@ struct type
unsigned length;
/* FIXME, these should probably be restricted to a Fortran-specific
field in some fashion. */
#define BOUND_CANNOT_BE_DETERMINED 5
#define BOUND_BY_REF_ON_STACK 4
#define BOUND_BY_VALUE_ON_STACK 3
#define BOUND_BY_REF_IN_REG 2
#define BOUND_BY_VALUE_IN_REG 1
#define BOUND_SIMPLE 0
int upper_bound_type;
int lower_bound_type;
/* Every type is now associated with a particular objfile, and the
type is allocated on the type_obstack for that objfile. One problem
however, is that there are times when gdb allocates new types while
@ -486,6 +500,17 @@ allocate_cplus_struct_type PARAMS ((struct type *));
by force_to_range_type. */
#define TYPE_DUMMY_RANGE(type) ((type)->vptr_fieldno)
/* Moto-specific stuff for FORTRAN arrays */
#define TYPE_ARRAY_UPPER_BOUND_TYPE(thistype) (thistype)->upper_bound_type
#define TYPE_ARRAY_LOWER_BOUND_TYPE(thistype) (thistype)->lower_bound_type
#define TYPE_ARRAY_UPPER_BOUND_VALUE(arraytype) \
(TYPE_FIELD_BITPOS((TYPE_FIELD_TYPE((arraytype),0)),1))
#define TYPE_ARRAY_LOWER_BOUND_VALUE(arraytype) \
(TYPE_FIELD_BITPOS((TYPE_FIELD_TYPE((arraytype),0)),0))
/* C++ */
#define TYPE_VPTR_BASETYPE(thistype) (thistype)->vptr_basetype
@ -605,6 +630,23 @@ extern struct type *builtin_type_chill_long;
extern struct type *builtin_type_chill_ulong;
extern struct type *builtin_type_chill_real;
/* Fortran (F77) types */
extern struct type *builtin_type_f_character;
extern struct type *builtin_type_f_integer;
extern struct type *builtin_type_f_logical;
extern struct type *builtin_type_f_logical_s1;
extern struct type *builtin_type_f_logical_s2;
extern struct type *builtin_type_f_integer;
extern struct type *builtin_type_f_integer_s2;
extern struct type *builtin_type_f_real;
extern struct type *builtin_type_f_real_s8;
extern struct type *builtin_type_f_real_s16;
extern struct type *builtin_type_f_complex_s8;
extern struct type *builtin_type_f_complex_s16;
extern struct type *builtin_type_f_complex_s32;
extern struct type *builtin_type_f_void;
/* Maximum and minimum values of built-in types */
#define MAX_OF_TYPE(t) \

1
gdb/language.c
View file

@ -166,6 +166,7 @@ set_language_command (ignore, from_tty)
printf_unfiltered ("c Use the C language\n");
printf_unfiltered ("c++ Use the C++ language\n");
printf_unfiltered ("chill Use the Chill language\n");
printf_unfiltered ("fortran Use the Fortran language\n");
printf_unfiltered ("modula-2 Use the Modula-2 language\n");
/* Restore the silly string. */
set_language(current_language->la_language);

3
gdb/language.h
View file

@ -34,6 +34,9 @@ struct objfile;
#define _LANG_c
#define _LANG_m2
#define _LANG_chill
#define _LANG_fortran
#define MAX_FORTRAN_DIMS 7 /* Maximum number of F77 array dims */
/* range_mode ==
range_mode_auto: range_check set automatically to default of language.

30
gdb/parse.c
View file

@ -466,7 +466,18 @@ length_of_subexp (expr, endpos)
oplen = 3;
break;
case OP_F77_LITERAL_COMPLEX:
oplen = 1;
args = 2;
break;
case OP_F77_SUBSTR:
oplen = 1;
args = 2;
break;
case OP_FUNCALL:
case OP_F77_UNDETERMINED_ARGLIST:
oplen = 3;
args = 1 + longest_to_int (expr->elts[endpos - 2].longconst);
break;
@ -524,7 +535,9 @@ length_of_subexp (expr, endpos)
/* Modula-2 */
case MULTI_SUBSCRIPT:
oplen=3;
/* Fortran */
case MULTI_F77_SUBSCRIPT:
oplen = 3;
args = 1 + longest_to_int (expr->elts[endpos- 2].longconst);
break;
@ -595,7 +608,18 @@ prefixify_subexp (inexpr, outexpr, inend, outbeg)
oplen = 3;
break;
case OP_F77_LITERAL_COMPLEX:
oplen = 1;
args = 2;
break;
case OP_F77_SUBSTR:
oplen = 1;
args = 2;
break;
case OP_FUNCALL:
case OP_F77_UNDETERMINED_ARGLIST:
oplen = 3;
args = 1 + longest_to_int (inexpr->elts[inend - 2].longconst);
break;
@ -657,7 +681,9 @@ prefixify_subexp (inexpr, outexpr, inend, outbeg)
/* Modula-2 */
case MULTI_SUBSCRIPT:
oplen=3;
/* Fortran */
case MULTI_F77_SUBSCRIPT:
oplen = 3;
args = 1 + longest_to_int (inexpr->elts[inend - 2].longconst);
break;

467
gdb/valops.c
View file

@ -33,31 +33,24 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
/* Local functions. */
static int
typecmp PARAMS ((int staticp, struct type *t1[], value t2[]));
static int typecmp PARAMS ((int staticp, struct type *t1[], value_ptr t2[]));
static CORE_ADDR
find_function_addr PARAMS ((value, struct type **));
static CORE_ADDR find_function_addr PARAMS ((value_ptr, struct type **));
static CORE_ADDR
value_push PARAMS ((CORE_ADDR, value));
static CORE_ADDR value_push PARAMS ((CORE_ADDR, value_ptr));
static CORE_ADDR
value_arg_push PARAMS ((CORE_ADDR, value));
static CORE_ADDR value_arg_push PARAMS ((CORE_ADDR, value_ptr));
static value
search_struct_field PARAMS ((char *, value, int, struct type *, int));
static value_ptr search_struct_field PARAMS ((char *, value_ptr, int,
struct type *, int));
static value
search_struct_method PARAMS ((char *, value *, value *, int, int *,
struct type *));
static value_ptr search_struct_method PARAMS ((char *, value_ptr *,
value_ptr *,
int, int *, struct type *));
static int
check_field_in PARAMS ((struct type *, const char *));
static CORE_ADDR
allocate_space_in_inferior PARAMS ((int));
static int check_field_in PARAMS ((struct type *, const char *));
static CORE_ADDR allocate_space_in_inferior PARAMS ((int));
/* Allocate NBYTES of space in the inferior using the inferior's malloc
and return a value that is a pointer to the allocated space. */
@ -66,11 +59,11 @@ static CORE_ADDR
allocate_space_in_inferior (len)
int len;
{
register value val;
register value_ptr val;
register struct symbol *sym;
struct minimal_symbol *msymbol;
struct type *type;
value blocklen;
value_ptr blocklen;
LONGEST maddr;
/* Find the address of malloc in the inferior. */
@ -115,10 +108,10 @@ allocate_space_in_inferior (len)
and if ARG2 is an lvalue it can be cast into anything at all. */
/* In C++, casts may change pointer or object representations. */
value
value_ptr
value_cast (type, arg2)
struct type *type;
register value arg2;
register value_ptr arg2;
{
register enum type_code code1;
register enum type_code code2;
@ -141,8 +134,8 @@ value_cast (type, arg2)
/* Look in the type of the source to see if it contains the
type of the target as a superclass. If so, we'll need to
offset the object in addition to changing its type. */
value v = search_struct_field (type_name_no_tag (type),
arg2, 0, VALUE_TYPE (arg2), 1);
value_ptr v = search_struct_field (type_name_no_tag (type),
arg2, 0, VALUE_TYPE (arg2), 1);
if (v)
{
VALUE_TYPE (v) = type;
@ -167,8 +160,8 @@ value_cast (type, arg2)
&& TYPE_CODE (t2) == TYPE_CODE_STRUCT
&& TYPE_NAME (t1) != 0) /* if name unknown, can't have supercl */
{
value v = search_struct_field (type_name_no_tag (t1),
value_ind (arg2), 0, t2, 1);
value_ptr v = search_struct_field (type_name_no_tag (t1),
value_ind (arg2), 0, t2, 1);
if (v)
{
v = value_addr (v);
@ -198,12 +191,12 @@ value_cast (type, arg2)
/* Create a value of type TYPE that is zero, and return it. */
value
value_ptr
value_zero (type, lv)
struct type *type;
enum lval_type lv;
{
register value val = allocate_value (type);
register value_ptr val = allocate_value (type);
memset (VALUE_CONTENTS (val), 0, TYPE_LENGTH (type));
VALUE_LVAL (val) = lv;
@ -220,12 +213,17 @@ value_zero (type, lv)
is tested in the VALUE_CONTENTS macro, which is used if and when
the contents are actually required. */
value
value_ptr
value_at (type, addr)
struct type *type;
CORE_ADDR addr;
{
register value val = allocate_value (type);
register value_ptr val;
if (TYPE_CODE (type) == TYPE_CODE_VOID)
error ("Attempt to dereference a generic pointer.");
val = allocate_value (type);
read_memory (addr, VALUE_CONTENTS_RAW (val), TYPE_LENGTH (type));
@ -237,12 +235,17 @@ value_at (type, addr)
/* Return a lazy value with type TYPE located at ADDR (cf. value_at). */
value
value_ptr
value_at_lazy (type, addr)
struct type *type;
CORE_ADDR addr;
{
register value val = allocate_value (type);
register value_ptr val;
if (TYPE_CODE (type) == TYPE_CODE_VOID)
error ("Attempt to dereference a generic pointer.");
val = allocate_value (type);
VALUE_LVAL (val) = lval_memory;
VALUE_ADDRESS (val) = addr;
@ -265,7 +268,7 @@ value_at_lazy (type, addr)
int
value_fetch_lazy (val)
register value val;
register value_ptr val;
{
CORE_ADDR addr = VALUE_ADDRESS (val) + VALUE_OFFSET (val);
@ -280,12 +283,12 @@ value_fetch_lazy (val)
/* Store the contents of FROMVAL into the location of TOVAL.
Return a new value with the location of TOVAL and contents of FROMVAL. */
value
value_ptr
value_assign (toval, fromval)
register value toval, fromval;
register value_ptr toval, fromval;
{
register struct type *type;
register value val;
register value_ptr val;
char raw_buffer[MAX_REGISTER_RAW_SIZE];
int use_buffer = 0;
@ -514,12 +517,12 @@ Can't handle bitfield which doesn't fit in a single register.");
/* Extend a value VAL to COUNT repetitions of its type. */
value
value_ptr
value_repeat (arg1, count)
value arg1;
value_ptr arg1;
int count;
{
register value val;
register value_ptr val;
if (VALUE_LVAL (arg1) != lval_memory)
error ("Only values in memory can be extended with '@'.");
@ -537,12 +540,12 @@ value_repeat (arg1, count)
return val;
}
value
value_ptr
value_of_variable (var, b)
struct symbol *var;
struct block *b;
{
value val;
value_ptr val;
FRAME fr;
if (b == NULL)
@ -590,9 +593,9 @@ value_of_variable (var, b)
the coercion to pointer type.
*/
value
value_ptr
value_coerce_array (arg1)
value arg1;
value_ptr arg1;
{
register struct type *type;
@ -615,9 +618,9 @@ value_coerce_array (arg1)
/* Given a value which is a function, return a value which is a pointer
to it. */
value
value_ptr
value_coerce_function (arg1)
value arg1;
value_ptr arg1;
{
if (VALUE_LVAL (arg1) != lval_memory)
@ -629,9 +632,9 @@ value_coerce_function (arg1)
/* Return a pointer value for the object for which ARG1 is the contents. */
value
value_ptr
value_addr (arg1)
value arg1;
value_ptr arg1;
{
struct type *type = VALUE_TYPE (arg1);
if (TYPE_CODE (type) == TYPE_CODE_REF)
@ -639,7 +642,7 @@ value_addr (arg1)
/* Copy the value, but change the type from (T&) to (T*).
We keep the same location information, which is efficient,
and allows &(&X) to get the location containing the reference. */
value arg2 = value_copy (arg1);
value_ptr arg2 = value_copy (arg1);
VALUE_TYPE (arg2) = lookup_pointer_type (TYPE_TARGET_TYPE (type));
return arg2;
}
@ -658,9 +661,9 @@ value_addr (arg1)
/* Given a value of a pointer type, apply the C unary * operator to it. */
value
value_ptr
value_ind (arg1)
value arg1;
value_ptr arg1;
{
COERCE_ARRAY (arg1);
@ -729,7 +732,7 @@ push_bytes (sp, buffer, len)
static CORE_ADDR
value_push (sp, arg)
register CORE_ADDR sp;
value arg;
value_ptr arg;
{
register int len = TYPE_LENGTH (VALUE_TYPE (arg));
@ -747,9 +750,9 @@ value_push (sp, arg)
/* Perform the standard coercions that are specified
for arguments to be passed to C functions. */
value
value_ptr
value_arg_coerce (arg)
value arg;
value_ptr arg;
{
register struct type *type;
@ -789,7 +792,7 @@ value_arg_coerce (arg)
static CORE_ADDR
value_arg_push (sp, arg)
register CORE_ADDR sp;
value arg;
value_ptr arg;
{
return value_push (sp, value_arg_coerce (arg));
}
@ -799,7 +802,7 @@ value_arg_push (sp, arg)
static CORE_ADDR
find_function_addr (function, retval_type)
value function;
value_ptr function;
struct type **retval_type;
{
register struct type *ftype = VALUE_TYPE (function);
@ -861,11 +864,11 @@ find_function_addr (function, retval_type)
May fail to return, if a breakpoint or signal is hit
during the execution of the function. */
value
value_ptr
call_function_by_hand (function, nargs, args)
value function;
value_ptr function;
int nargs;
value *args;
value_ptr *args;
{
register CORE_ADDR sp;
register int i;
@ -1018,30 +1021,30 @@ call_function_by_hand (function, nargs, args)
#if defined (REG_STRUCT_HAS_ADDR)
{
/* This is a machine like the sparc, where we need to pass a pointer
/* This is a machine like the sparc, where we may need to pass a pointer
to the structure, not the structure itself. */
if (REG_STRUCT_HAS_ADDR (using_gcc))
for (i = nargs - 1; i >= 0; i--)
if (TYPE_CODE (VALUE_TYPE (args[i])) == TYPE_CODE_STRUCT)
{
CORE_ADDR addr;
for (i = nargs - 1; i >= 0; i--)
if (TYPE_CODE (VALUE_TYPE (args[i])) == TYPE_CODE_STRUCT
&& REG_STRUCT_HAS_ADDR (using_gcc, VALUE_TYPE (args[i])))
{
CORE_ADDR addr;
#if !(1 INNER_THAN 2)
/* The stack grows up, so the address of the thing we push
is the stack pointer before we push it. */
addr = sp;
/* The stack grows up, so the address of the thing we push
is the stack pointer before we push it. */
addr = sp;
#endif
/* Push the structure. */
sp = value_push (sp, args[i]);
/* Push the structure. */
sp = value_push (sp, args[i]);
#if 1 INNER_THAN 2
/* The stack grows down, so the address of the thing we push
is the stack pointer after we push it. */
addr = sp;
/* The stack grows down, so the address of the thing we push
is the stack pointer after we push it. */
addr = sp;
#endif
/* The value we're going to pass is the address of the thing
we just pushed. */
args[i] = value_from_longest (lookup_pointer_type (value_type),
(LONGEST) addr);
}
/* The value we're going to pass is the address of the thing
we just pushed. */
args[i] = value_from_longest (lookup_pointer_type (value_type),
(LONGEST) addr);
}
}
#endif /* REG_STRUCT_HAS_ADDR. */
@ -1146,11 +1149,11 @@ the function call).", name);
}
}
#else /* no CALL_DUMMY. */
value
value_ptr
call_function_by_hand (function, nargs, args)
value function;
value_ptr function;
int nargs;
value *args;
value_ptr *args;
{
error ("Cannot invoke functions on this machine.");
}
@ -1167,16 +1170,16 @@ call_function_by_hand (function, nargs, args)
first element, and all elements must have the same size (though we
don't currently enforce any restriction on their types). */
value
value_ptr
value_array (lowbound, highbound, elemvec)
int lowbound;
int highbound;
value *elemvec;
value_ptr *elemvec;
{
int nelem;
int idx;
int typelength;
value val;
value_ptr val;
struct type *rangetype;
struct type *arraytype;
CORE_ADDR addr;
@ -1228,12 +1231,12 @@ value_array (lowbound, highbound, elemvec)
zero and an upper bound of LEN - 1. Also note that the string may contain
embedded null bytes. */
value
value_ptr
value_string (ptr, len)
char *ptr;
int len;
{
value val;
value_ptr val;
struct type *rangetype;
struct type *stringtype;
CORE_ADDR addr;
@ -1273,7 +1276,7 @@ static int
typecmp (staticp, t1, t2)
int staticp;
struct type *t1[];
value t2[];
value_ptr t2[];
{
int i;
@ -1327,10 +1330,10 @@ typecmp (staticp, t1, t2)
If LOOKING_FOR_BASECLASS, then instead of looking for struct fields,
look for a baseclass named NAME. */
static value
static value_ptr
search_struct_field (name, arg1, offset, type, looking_for_baseclass)
char *name;
register value arg1;
register value_ptr arg1;
int offset;
register struct type *type;
int looking_for_baseclass;
@ -1346,7 +1349,7 @@ search_struct_field (name, arg1, offset, type, looking_for_baseclass)
if (t_field_name && STREQ (t_field_name, name))
{
value v;
value_ptr v;
if (TYPE_FIELD_STATIC (type, i))
{
char *phys_name = TYPE_FIELD_STATIC_PHYSNAME (type, i);
@ -1368,7 +1371,7 @@ search_struct_field (name, arg1, offset, type, looking_for_baseclass)
for (i = TYPE_N_BASECLASSES (type) - 1; i >= 0; i--)
{
value v;
value_ptr v;
/* If we are looking for baseclasses, this is what we get when we
hit them. But it could happen that the base part's member name
is not yet filled in. */
@ -1378,7 +1381,7 @@ search_struct_field (name, arg1, offset, type, looking_for_baseclass)
if (BASETYPE_VIA_VIRTUAL (type, i))
{
value v2;
value_ptr v2;
/* Fix to use baseclass_offset instead. FIXME */
baseclass_addr (type, i, VALUE_CONTENTS (arg1) + offset,
&v2, (int *)NULL);
@ -1407,15 +1410,15 @@ search_struct_field (name, arg1, offset, type, looking_for_baseclass)
If found, return value, else if name matched and args not return (value)-1,
else return NULL. */
static value
static value_ptr
search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
char *name;
register value *arg1p, *args;
register value_ptr *arg1p, *args;
int offset, *static_memfuncp;
register struct type *type;
{
int i;
value v;
value_ptr v;
int name_matched = 0;
char dem_opname[64];
@ -1448,11 +1451,11 @@ search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
TYPE_FN_FIELD_ARGS (f, j), args))
{
if (TYPE_FN_FIELD_VIRTUAL_P (f, j))
return (value)value_virtual_fn_field (arg1p, f, j, type, offset);
return value_virtual_fn_field (arg1p, f, j, type, offset);
if (TYPE_FN_FIELD_STATIC_P (f, j) && static_memfuncp)
*static_memfuncp = 1;
v = (value)value_fn_field (arg1p, f, j, type, offset);
if (v != (value)NULL) return v;
v = value_fn_field (arg1p, f, j, type, offset);
if (v != NULL) return v;
}
j--;
}
@ -1475,7 +1478,7 @@ search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
}
v = search_struct_method (name, arg1p, args, base_offset + offset,
static_memfuncp, TYPE_BASECLASS (type, i));
if (v == (value) -1)
if (v == (value_ptr) -1)
{
name_matched = 1;
}
@ -1486,7 +1489,7 @@ search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
return v;
}
}
if (name_matched) return (value) -1;
if (name_matched) return (value_ptr) -1;
else return NULL;
}
@ -1504,15 +1507,15 @@ search_struct_method (name, arg1p, args, offset, static_memfuncp, type)
ERR is an error message to be printed in case the field is not found. */
value
value_ptr
value_struct_elt (argp, args, name, static_memfuncp, err)
register value *argp, *args;
register value_ptr *argp, *args;
char *name;
int *static_memfuncp;
char *err;
{
register struct type *t;
value v;
value_ptr v;
COERCE_ARRAY (*argp);
@ -1558,7 +1561,7 @@ value_struct_elt (argp, args, name, static_memfuncp, err)
v = search_struct_method (name, argp, args, 0, static_memfuncp, t);
if (v == (value) -1)
if (v == (value_ptr) -1)
error ("Cannot take address of a method");
else if (v == 0)
{
@ -1575,8 +1578,8 @@ value_struct_elt (argp, args, name, static_memfuncp, err)
if (!args[1])
{
/* destructors are a special case. */
v = (value)value_fn_field (NULL, TYPE_FN_FIELDLIST1 (t, 0),
TYPE_FN_FIELDLIST_LENGTH (t, 0), 0, 0);
v = value_fn_field (NULL, TYPE_FN_FIELDLIST1 (t, 0),
TYPE_FN_FIELDLIST_LENGTH (t, 0), 0, 0);
if (!v) error("could not find destructor function named %s.", name);
else return v;
}
@ -1588,7 +1591,7 @@ value_struct_elt (argp, args, name, static_memfuncp, err)
else
v = search_struct_method (name, argp, args, 0, static_memfuncp, t);
if (v == (value) -1)
if (v == (value_ptr) -1)
{
error("Argument list of %s mismatch with component in the structure.", name);
}
@ -1671,7 +1674,7 @@ check_field_in (type, name)
int
check_field (arg1, name)
register value arg1;
register value_ptr arg1;
const char *name;
{
register struct type *t;
@ -1702,7 +1705,7 @@ check_field (arg1, name)
"pointers to member functions". This function is used
to resolve user expressions of the form "DOMAIN::NAME". */
value
value_ptr
value_struct_elt_for_reference (domain, offset, curtype, name, intype)
struct type *domain, *curtype, *intype;
int offset;
@ -1710,7 +1713,7 @@ value_struct_elt_for_reference (domain, offset, curtype, name, intype)
{
register struct type *t = curtype;
register int i;
value v;
value_ptr v;
if ( TYPE_CODE (t) != TYPE_CODE_STRUCT
&& TYPE_CODE (t) != TYPE_CODE_UNION)
@ -1822,7 +1825,7 @@ value_struct_elt_for_reference (domain, offset, curtype, name, intype)
}
for (i = TYPE_N_BASECLASSES (t) - 1; i >= 0; i--)
{
value v;
value_ptr v;
int base_offset;
if (BASETYPE_VIA_VIRTUAL (t, i))
@ -1843,7 +1846,7 @@ value_struct_elt_for_reference (domain, offset, curtype, name, intype)
/* C++: return the value of the class instance variable, if one exists.
Flag COMPLAIN signals an error if the request is made in an
inappropriate context. */
value
value_ptr
value_of_this (complain)
int complain;
{
@ -1852,7 +1855,7 @@ value_of_this (complain)
struct block *b;
int i;
static const char funny_this[] = "this";
value this;
value_ptr this;
if (selected_frame == 0)
if (complain)
@ -1890,3 +1893,243 @@ value_of_this (complain)
error ("`this' argument at unknown address");
return this;
}
/* Create a value for a literal string. We copy data into a local
(NOT inferior's memory) buffer, and then set up an array value.
The array bounds are set from LOWBOUND and HIGHBOUND, and the array is
populated from the values passed in ELEMVEC.
The element type of the array is inherited from the type of the
first element, and all elements must have the same size (though we
don't currently enforce any restriction on their types). */
value_ptr
f77_value_literal_string (lowbound, highbound, elemvec)
int lowbound;
int highbound;
value_ptr *elemvec;
{
int nelem;
int idx;
int typelength;
register value_ptr val;
struct type *rangetype;
struct type *arraytype;
CORE_ADDR addr;
/* Validate that the bounds are reasonable and that each of the elements
have the same size. */
nelem = highbound - lowbound + 1;
if (nelem <= 0)
error ("bad array bounds (%d, %d)", lowbound, highbound);
typelength = TYPE_LENGTH (VALUE_TYPE (elemvec[0]));
for (idx = 0; idx < nelem; idx++)
{
if (TYPE_LENGTH (VALUE_TYPE (elemvec[idx])) != typelength)
error ("array elements must all be the same size");
}
/* Make sure we are dealing with characters */
if (typelength != 1)
error ("Found a non character type in a literal string ");
/* Allocate space to store the array */
addr = malloc (nelem);
for (idx = 0; idx < nelem; idx++)
{
memcpy (addr + (idx), VALUE_CONTENTS (elemvec[idx]), 1);
}
rangetype = create_range_type ((struct type *) NULL, builtin_type_int,
lowbound, highbound);
arraytype = f77_create_literal_string_type ((struct type *) NULL,
rangetype);
val = allocate_value (arraytype);
/* Make sure that this the rest of the world knows that this is
a standard literal string, not one that is a substring of
some base */
VALUE_SUBSTRING_START (val) = NULL;
VALUE_LAZY (val) = 0;
VALUE_LITERAL_DATA (val) = addr;
/* Since this is a standard literal string with no real lval,
make sure that value_lval indicates this fact */
VALUE_LVAL (val) = not_lval;
return val;
}
/* Create a value for a substring. We copy data into a local
(NOT inferior's memory) buffer, and then set up an array value.
The array bounds for the string are (1:(to-from +1))
The elements of the string are all characters. */
value_ptr
f77_value_substring (str, from, to)
value_ptr str;
int from;
int to;
{
int nelem;
register value_ptr val;
struct type *rangetype;
struct type *arraytype;
struct internalvar *var;
CORE_ADDR addr;
/* Validate that the bounds are reasonable. */
nelem = to - from + 1;
if (nelem <= 0)
error ("bad substring bounds (%d, %d)", from, to);
rangetype = create_range_type ((struct type *) NULL, builtin_type_int,
1, nelem);
arraytype = f77_create_literal_string_type ((struct type *) NULL,
rangetype);
val = allocate_value (arraytype);
/* Allocate space to store the substring array */
addr = malloc (nelem);
/* Copy over the data */
/* In case we ever try to use this substring on the LHS of an assignment
remember where the SOURCE substring begins, for lval_memory
types this ptr is to a location in legal inferior memory,
for lval_internalvars it is a ptr. to superior memory. This
helps us out later when we do assigments like:
set var ARR(2:3) = 'ab'
*/
if (VALUE_LVAL (str) == lval_memory)
{
if (VALUE_SUBSTRING_START (str) == NULL)
{
/* This is a regular lval_memory string located in the
inferior */
VALUE_SUBSTRING_START (val) = VALUE_ADDRESS (str) + (from - 1);
target_read_memory (VALUE_SUBSTRING_START (val), addr, nelem);
}
else
{
#if 0
/* str is a substring allocated in the superior. Just
do a memcpy */
VALUE_SUBSTRING_START(val) = VALUE_LITERAL_DATA(str)+(from - 1);
memcpy(addr,VALUE_SUBSTRING_START(val),nelem);
#else
error ("Cannot get substrings of substrings");
#endif
}
}
else
if (VALUE_LVAL(str) == lval_internalvar)
{
/* Internal variables of type TYPE_CODE_LITERAL_STRING
have their data located in the superior
process not the inferior */
var = VALUE_INTERNALVAR (str);
if (VALUE_SUBSTRING_START (str) == NULL)
VALUE_SUBSTRING_START (val) =
VALUE_LITERAL_DATA (var->value) + (from - 1);
else
#if 0
VALUE_SUBSTRING_START(val)=VALUE_LITERAL_DATA(str)+(from -1);
#else
error ("Cannot get substrings of substrings");
#endif
memcpy (addr, VALUE_SUBSTRING_START (val), nelem);
}
else
error ("Substrings can not be applied to this data item");
VALUE_LAZY (val) = 0;
VALUE_LITERAL_DATA (val) = addr;
/* This literal string's *data* is located in the superior BUT
we do need to know where it came from (i.e. was the source
string an internalvar or a regular lval_memory variable), so
we set the lval field to indicate this. This will be useful
when we use this value on the LHS of an expr. */
VALUE_LVAL (val) = VALUE_LVAL (str);
return val;
}
/* Create a value for a FORTRAN complex number. Currently most of
the time values are coerced to COMPLEX*16 (i.e. a complex number
composed of 2 doubles. This really should be a smarter routine
that figures out precision inteligently as opposed to assuming
doubles. FIXME: fmb */
value_ptr
f77_value_literal_complex (arg1, arg2, size)
value_ptr arg1;
value_ptr arg2;
int size;
{
struct type *complex_type;
register value_ptr val;
char *addr;
if (size != 8 && size != 16 && size != 32)
error ("Cannot create number of type 'complex*%d'", size);
/* If either value comprising a complex number is a non-floating
type, cast to double. */
if (TYPE_CODE (VALUE_TYPE (arg1)) != TYPE_CODE_FLT)
arg1 = value_cast (builtin_type_f_real_s8, arg1);
if (TYPE_CODE (VALUE_TYPE (arg1)) != TYPE_CODE_FLT)
arg2 = value_cast (builtin_type_f_real_s8, arg2);
complex_type = f77_create_literal_complex_type (VALUE_TYPE (arg1),
VALUE_TYPE (arg2),
size);
val = allocate_value (complex_type);
/* Now create a pointer to enough memory to hold the the two args */
addr = malloc (TYPE_LENGTH (complex_type));
/* Copy over the two components */
memcpy (addr, VALUE_CONTENTS_RAW (arg1), TYPE_LENGTH (VALUE_TYPE (arg1)));
memcpy (addr + TYPE_LENGTH (VALUE_TYPE (arg1)), VALUE_CONTENTS_RAW (arg2),
TYPE_LENGTH (VALUE_TYPE (arg2)));
VALUE_ADDRESS (val) = 0; /* Not located in the inferior */
VALUE_LAZY (val) = 0;
VALUE_LITERAL_DATA (val) = addr;
/* Since this is a literal value, make sure that value_lval indicates
this fact */
VALUE_LVAL (val) = not_lval;
return val;
}

32
gdb/value.h
View file

@ -139,6 +139,28 @@ extern int value_fetch_lazy PARAMS ((value_ptr val));
#define VALUE_REGNO(val) (val)->regno
#define VALUE_OPTIMIZED_OUT(val) ((val)->optimized_out)
/* This is probably not the right thing to do for in-gdb arrays. FIXME */
/* Overload the contents field to store literal data for
arrays. */
#define VALUE_LITERAL_DATA(val) ((val)->aligner.contents[0])
/* Overload the frame address field to contain a pointer to
the base substring, for F77 string substring operators.
We use this ONLY when doing operations of the form
FOO= 'hello'
FOO(2:4) = 'foo'
In the above case VALUE_SUBSTRING_START would point to
FOO(2) in the original FOO string.
Depending on whether the base object is allocated in the
inferior or the superior process, VALUE_SUBSTRING_START
contains a ptr. to memory in the relevant area. */
#define VALUE_SUBSTRING_START(val) VALUE_FRAME(val)
/* Convert a REF to the object referenced. */
#define COERCE_REF(arg) \
@ -433,6 +455,10 @@ print_floating PARAMS ((char *valaddr, struct type *type, GDB_FILE *stream));
extern int value_print PARAMS ((value_ptr val, GDB_FILE *stream, int format,
enum val_prettyprint pretty));
extern void
value_print_array_elements PARAMS ((value_ptr val, GDB_FILE* stream,
int format, enum val_prettyprint pretty));
extern value_ptr
value_release_to_mark PARAMS ((value_ptr mark));
@ -475,4 +501,10 @@ extern int baseclass_offset PARAMS ((struct type *, int, value_ptr, int));
extern value_ptr call_function_by_hand PARAMS ((value_ptr, int, value_ptr *));
extern value_ptr f77_value_literal_complex PARAMS ((value_ptr, value_ptr, int));
extern value_ptr f77_value_literal_string PARAMS ((int, int, value_ptr *));
extern value_ptr f77_value_substring PARAMS ((value_ptr, int, int));
#endif /* !defined (VALUE_H) */