diff options
| -rw-r--r-- | gdb/ChangeLog | 37 | ||||
| -rw-r--r-- | gdb/f-exp.y | 1246 | ||||
| -rw-r--r-- | gdb/f-lang.c | 945 | ||||
| -rw-r--r-- | gdb/f-lang.h | 90 | ||||
| -rw-r--r-- | gdb/f-typeprint.c | 457 | ||||
| -rw-r--r-- | gdb/f-valprint.c | 889 | ||||
| -rw-r--r-- | gdb/gdbtypes.c | 80 | ||||
| -rw-r--r-- | gdb/gdbtypes.h | 50 | ||||
| -rw-r--r-- | gdb/language.c | 1 | ||||
| -rw-r--r-- | gdb/language.h | 3 | ||||
| -rw-r--r-- | gdb/parse.c | 30 | ||||
| -rw-r--r-- | gdb/valops.c | 467 | ||||
| -rw-r--r-- | gdb/value.h | 32 |
13 files changed, 4209 insertions, 118 deletions
diff --git a/gdb/ChangeLog b/gdb/ChangeLog index fcdd266..a7cc010 100644 --- a/gdb/ChangeLog +++ b/gdb/ChangeLog @@ -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 diff --git a/gdb/f-exp.y b/gdb/f-exp.y new file mode 100644 index 0000000..27eda23 --- /dev/null +++ b/gdb/f-exp.y @@ -0,0 +1,1246 @@ +/* YACC parser for Fortran expressions, for GDB. + Copyright 1986, 1989, 1990, 1991, 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. */ + +/* This was blantantly ripped off the C expression parser, please + be aware of that as you look at its basic structure -FMB */ + +/* Parse a F77 expression from text in a string, + and return the result as a struct expression pointer. + That structure contains arithmetic operations in reverse polish, + with constants represented by operations that are followed by special data. + See expression.h for the details of the format. + What is important here is that it can be built up sequentially + during the process of parsing; the lower levels of the tree always + come first in the result. + + Note that malloc's and realloc's in this file are transformed to + xmalloc and xrealloc respectively by the same sed command in the + makefile that remaps any other malloc/realloc inserted by the parser + generator. Doing this with #defines and trying to control the interaction + with include files (<malloc.h> and <stdlib.h> for example) just became + too messy, particularly when such includes can be inserted at random + times by the parser generator. */ + +%{ + +#include "defs.h" +#include "expression.h" +#include "parser-defs.h" +#include "value.h" +#include "language.h" +#include "f-lang.h" +#include "bfd.h" /* Required by objfiles.h. */ +#include "symfile.h" /* Required by objfiles.h. */ +#include "objfiles.h" /* For have_full_symbols and have_partial_symbols */ + +/* Remap normal yacc parser interface names (yyparse, yylex, yyerror, etc), + as well as gratuitiously global symbol names, so we can have multiple + yacc generated parsers in gdb. Note that these are only the variables + produced by yacc. If other parser generators (bison, byacc, etc) produce + additional global names that conflict at link time, then those parser + generators need to be fixed instead of adding those names to this list. */ + +#define yymaxdepth f_maxdepth +#define yyparse f_parse +#define yylex f_lex +#define yyerror f_error +#define yylval f_lval +#define yychar f_char +#define yydebug f_debug +#define yypact f_pact +#define yyr1 f_r1 +#define yyr2 f_r2 +#define yydef f_def +#define yychk f_chk +#define yypgo f_pgo +#define yyact f_act +#define yyexca f_exca +#define yyerrflag f_errflag +#define yynerrs f_nerrs +#define yyps f_ps +#define yypv f_pv +#define yys f_s +#define yy_yys f_yys +#define yystate f_state +#define yytmp f_tmp +#define yyv f_v +#define yy_yyv f_yyv +#define yyval f_val +#define yylloc f_lloc +#define yyreds f_reds /* With YYDEBUG defined */ +#define yytoks f_toks /* With YYDEBUG defined */ + +#ifndef YYDEBUG +#define YYDEBUG 1 /* Default to no yydebug support */ +#endif + +int yyparse PARAMS ((void)); + +static int yylex PARAMS ((void)); + +void yyerror PARAMS ((char *)); + +%} + +/* Although the yacc "value" of an expression is not used, + since the result is stored in the structure being created, + other node types do have values. */ + +%union + { + LONGEST lval; + struct { + LONGEST val; + struct type *type; + } typed_val; + double dval; + struct symbol *sym; + struct type *tval; + struct stoken sval; + struct ttype tsym; + struct symtoken ssym; + int voidval; + struct block *bval; + enum exp_opcode opcode; + struct internalvar *ivar; + + struct type **tvec; + int *ivec; + } + +%{ +/* YYSTYPE gets defined by %union */ +static int parse_number PARAMS ((char *, int, int, YYSTYPE *)); +%} + +%type <voidval> exp type_exp start variable +%type <tval> type typebase +%type <tvec> nonempty_typelist +/* %type <bval> block */ + +/* Fancy type parsing. */ +%type <voidval> func_mod direct_abs_decl abs_decl +%type <tval> ptype + +%token <typed_val> INT +%token <dval> FLOAT + +/* Both NAME and TYPENAME tokens represent symbols in the input, + and both convey their data as strings. + But a TYPENAME is a string that happens to be defined as a typedef + or builtin type name (such as int or char) + and a NAME is any other symbol. + Contexts where this distinction is not important can use the + nonterminal "name", which matches either NAME or TYPENAME. */ + +%token <sval> STRING_LITERAL +%token <lval> BOOLEAN_LITERAL +%token <ssym> NAME +%token <tsym> TYPENAME +%type <sval> name +%type <ssym> name_not_typename +%type <tsym> typename + +/* A NAME_OR_INT is a symbol which is not known in the symbol table, + but which would parse as a valid number in the current input radix. + E.g. "c" when input_radix==16. Depending on the parse, it will be + turned into a name or into a number. */ + +%token <ssym> NAME_OR_INT + +%token SIZEOF +%token ERROR + +/* Special type cases, put in to allow the parser to distinguish different + legal basetypes. */ +%token INT_KEYWORD INT_S2_KEYWORD LOGICAL_S1_KEYWORD LOGICAL_S2_KEYWORD +%token LOGICAL_KEYWORD REAL_KEYWORD REAL_S8_KEYWORD REAL_S16_KEYWORD +%token COMPLEX_S8_KEYWORD COMPLEX_S16_KEYWORD COMPLEX_S32_KEYWORD +%token BOOL_AND BOOL_OR BOOL_NOT +%token <lval> LAST REGNAME CHARACTER + +%token <ivar> VARIABLE + +%token <opcode> ASSIGN_MODIFY + +%left ',' +%left ABOVE_COMMA +%right '=' ASSIGN_MODIFY +%right '?' +%left BOOL_OR +%right BOOL_NOT +%left BOOL_AND +%left '|' +%left '^' +%left '&' +%left EQUAL NOTEQUAL +%left LESSTHAN GREATERTHAN LEQ GEQ +%left LSH RSH +%left '@' +%left '+' '-' +%left '*' '/' '%' +%right UNARY +%right '(' + + +%% + +start : exp + | type_exp + ; + +type_exp: type + { write_exp_elt_opcode(OP_TYPE); + write_exp_elt_type($1); + write_exp_elt_opcode(OP_TYPE); } + ; + + +exp : '(' exp ')' + { } + ; + +/* Expressions, not including the comma operator. */ +exp : '*' exp %prec UNARY + { write_exp_elt_opcode (UNOP_IND); } + +exp : '&' exp %prec UNARY + { write_exp_elt_opcode (UNOP_ADDR); } + +exp : '-' exp %prec UNARY + { write_exp_elt_opcode (UNOP_NEG); } + ; + +exp : BOOL_NOT exp %prec UNARY + { write_exp_elt_opcode (UNOP_LOGICAL_NOT); } + ; + +exp : '~' exp %prec UNARY + { write_exp_elt_opcode (UNOP_COMPLEMENT); } + ; + +exp : SIZEOF exp %prec UNARY + { write_exp_elt_opcode (UNOP_SIZEOF); } + ; + +/* No more explicit array operators, we treat everything in F77 as + a function call. The disambiguation as to whether we are + doing a subscript operation or a function call is done + later in eval.c. */ + +exp : exp '(' + { start_arglist (); } + arglist ')' + { write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); + write_exp_elt_longcst ((LONGEST) end_arglist ()); + write_exp_elt_opcode (OP_F77_UNDETERMINED_ARGLIST); } + ; + +arglist : + ; + +arglist : exp + { arglist_len = 1; } + ; + +arglist : substring + { arglist_len = 2;} + +arglist : arglist ',' exp %prec ABOVE_COMMA + { arglist_len++; } + ; + +substring: exp ':' exp %prec ABOVE_COMMA + { } + ; + + +complexnum: exp ',' exp + { } + ; + +exp : '(' complexnum ')' + { write_exp_elt_opcode(OP_F77_LITERAL_COMPLEX); } + ; + +exp : '(' type ')' exp %prec UNARY + { write_exp_elt_opcode (UNOP_CAST); + write_exp_elt_type ($2); + write_exp_elt_opcode (UNOP_CAST); } + ; + +/* Binary operators in order of decreasing precedence. */ + +exp : exp '@' exp + { write_exp_elt_opcode (BINOP_REPEAT); } + ; + +exp : exp '*' exp + { write_exp_elt_opcode (BINOP_MUL); } + ; + +exp : exp '/' exp + { write_exp_elt_opcode (BINOP_DIV); } + ; + +exp : exp '%' exp + { write_exp_elt_opcode (BINOP_REM); } + ; + +exp : exp '+' exp + { write_exp_elt_opcode (BINOP_ADD); } + ; + +exp : exp '-' exp + { write_exp_elt_opcode (BINOP_SUB); } + ; + +exp : exp LSH exp + { write_exp_elt_opcode (BINOP_LSH); } + ; + +exp : exp RSH exp + { write_exp_elt_opcode (BINOP_RSH); } + ; + +exp : exp EQUAL exp + { write_exp_elt_opcode (BINOP_EQUAL); } + ; + +exp : exp NOTEQUAL exp + { write_exp_elt_opcode (BINOP_NOTEQUAL); } + ; + +exp : exp LEQ exp + { write_exp_elt_opcode (BINOP_LEQ); } + ; + +exp : exp GEQ exp + { write_exp_elt_opcode (BINOP_GEQ); } + ; + +exp : exp LESSTHAN exp + { write_exp_elt_opcode (BINOP_LESS); } + ; + +exp : exp GREATERTHAN exp + { write_exp_elt_opcode (BINOP_GTR); } + ; + +exp : exp '&' exp + { write_exp_elt_opcode (BINOP_BITWISE_AND); } + ; + +exp : exp '^' exp + { write_exp_elt_opcode (BINOP_BITWISE_XOR); } + ; + +exp : exp '|' exp + { write_exp_elt_opcode (BINOP_BITWISE_IOR); } + ; + +exp : exp BOOL_AND exp + { write_exp_elt_opcode (BINOP_LOGICAL_AND); } + ; + + +exp : exp BOOL_OR exp + { write_exp_elt_opcode (BINOP_LOGICAL_OR); } + ; + +exp : exp '=' exp + { write_exp_elt_opcode (BINOP_ASSIGN); } + ; + +exp : exp ASSIGN_MODIFY exp + { write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); + write_exp_elt_opcode ($2); + write_exp_elt_opcode (BINOP_ASSIGN_MODIFY); } + ; + +exp : INT + { write_exp_elt_opcode (OP_LONG); + write_exp_elt_type ($1.type); + write_exp_elt_longcst ((LONGEST)($1.val)); + write_exp_elt_opcode (OP_LONG); } + ; + +exp : NAME_OR_INT + { YYSTYPE val; + parse_number ($1.stoken.ptr, $1.stoken.length, 0, &val); + write_exp_elt_opcode (OP_LONG); + write_exp_elt_type (val.typed_val.type); + write_exp_elt_longcst ((LONGEST)val.typed_val.val); + write_exp_elt_opcode (OP_LONG); + } + ; + +exp : FLOAT + { write_exp_elt_opcode (OP_DOUBLE); + write_exp_elt_type (builtin_type_f_real_s8); + write_exp_elt_dblcst ($1); + write_exp_elt_opcode (OP_DOUBLE); } + ; + +exp : variable + ; + +exp : LAST + { write_exp_elt_opcode (OP_LAST); + write_exp_elt_longcst ((LONGEST) $1); + write_exp_elt_opcode (OP_LAST); } + ; + +exp : REGNAME + { write_exp_elt_opcode (OP_REGISTER); + write_exp_elt_longcst ((LONGEST) $1); + write_exp_elt_opcode (OP_REGISTER); } + ; + +exp : VARIABLE + { write_exp_elt_opcode (OP_INTERNALVAR); + write_exp_elt_intern ($1); + write_exp_elt_opcode (OP_INTERNALVAR); } + ; + +exp : SIZEOF '(' type ')' %prec UNARY + { write_exp_elt_opcode (OP_LONG); + write_exp_elt_type (builtin_type_f_integer); + write_exp_elt_longcst ((LONGEST) TYPE_LENGTH ($3)); + write_exp_elt_opcode (OP_LONG); } + ; + +exp : BOOLEAN_LITERAL + { write_exp_elt_opcode (OP_BOOL); + write_exp_elt_longcst ((LONGEST) $1); + write_exp_elt_opcode (OP_BOOL); + } + ; + +exp : STRING_LITERAL + { /* In F77, we encounter string literals + basically in only one place: + when we are setting up manual parameter + lists to functions we call by hand or + when setting string vars to manual values. + These are character*N type variables. + They are treated specially behind the + scenes. Remember that the literal strings's + OPs are being emitted in reverse order, thus + we first have the elements and then + the array descriptor itself. */ + char *sp = $1.ptr; int count = $1.length; + + while (count-- > 0) + { + write_exp_elt_opcode (OP_LONG); + write_exp_elt_type (builtin_type_f_character); + write_exp_elt_longcst ((LONGEST)(*sp++)); + write_exp_elt_opcode (OP_LONG); + } + write_exp_elt_opcode (OP_ARRAY); + write_exp_elt_longcst ((LONGEST) 1); + write_exp_elt_longcst ((LONGEST) ($1.length)); + write_exp_elt_opcode (OP_ARRAY); + } + + ; + +variable: name_not_typename + { struct symbol *sym = $1.sym; + + if (sym) + { + if (symbol_read_needs_frame (sym)) + { + if (innermost_block == 0 || + contained_in (block_found, + innermost_block)) + innermost_block = block_found; + } + write_exp_elt_opcode (OP_VAR_VALUE); + write_exp_elt_sym (sym); + write_exp_elt_opcode (OP_VAR_VALUE); + break; + } + else + { + struct minimal_symbol *msymbol; + register char *arg = copy_name ($1.stoken); + + msymbol = lookup_minimal_symbol (arg, NULL); + if (msymbol != NULL) + { + write_exp_msymbol (msymbol, + lookup_function_type (builtin_type_int), + builtin_type_int); + } + else if (!have_full_symbols () && !have_partial_symbols ()) + error ("No symbol table is loaded. Use the \"file\" command."); + else + error ("No symbol \"%s\" in current context.", + copy_name ($1.stoken)); + } + } + ; + + +type : ptype + ; + +ptype : typebase + | typebase abs_decl + { + /* This is where the interesting stuff happens. */ + int done = 0; + int array_size; + struct type *follow_type = $1; + struct type *range_type; + + while (!done) + switch (pop_type ()) + { + case tp_end: + done = 1; + break; + case tp_pointer: + follow_type = lookup_pointer_type (follow_type); + break; + case tp_reference: + follow_type = lookup_reference_type (follow_type); + break; + case tp_array: + array_size = pop_type_int (); + if (array_size != -1) + { + range_type = + create_range_type ((struct type *) NULL, + builtin_type_f_integer, 0, + array_size - 1); + follow_type = + create_array_type ((struct type *) NULL, + follow_type, range_type); + } + else + follow_type = lookup_pointer_type (follow_type); + break; + case tp_function: + follow_type = lookup_function_type (follow_type); + break; + } + $$ = follow_type; + } + ; + +abs_decl: '*' + { push_type (tp_pointer); $$ = 0; } + | '*' abs_decl + { push_type (tp_pointer); $$ = $2; } + | '&' + { push_type (tp_reference); $$ = 0; } + | '&' abs_decl + { push_type (tp_reference); $$ = $2; } + | direct_abs_decl + ; + +direct_abs_decl: '(' abs_decl ')' + { $$ = $2; } + | direct_abs_decl func_mod + { push_type (tp_function); } + | func_mod + { push_type (tp_function); } + ; + +func_mod: '(' ')' + { $$ = 0; } + | '(' nonempty_typelist ')' + { free ((PTR)$2); $$ = 0; } + ; + +typebase /* Implements (approximately): (type-qualifier)* type-specifier */ + : TYPENAME + { $$ = $1.type; } + | INT_KEYWORD + { $$ = builtin_type_f_integer; } + | INT_S2_KEYWORD + { $$ = builtin_type_f_integer_s2; } + | CHARACTER + { $$ = builtin_type_f_character; } + | LOGICAL_KEYWORD + { $$ = builtin_type_f_logical;} + | LOGICAL_S2_KEYWORD + { $$ = builtin_type_f_logical_s2;} + | LOGICAL_S1_KEYWORD + { $$ = builtin_type_f_logical_s1;} + | REAL_KEYWORD + { $$ = builtin_type_f_real;} + | REAL_S8_KEYWORD + { $$ = builtin_type_f_real_s8;} + | REAL_S16_KEYWORD + { $$ = builtin_type_f_real_s16;} + | COMPLEX_S8_KEYWORD + { $$ = builtin_type_f_complex_s8;} + | COMPLEX_S16_KEYWORD + { $$ = builtin_type_f_complex_s16;} + | COMPLEX_S32_KEYWORD + { $$ = builtin_type_f_complex_s32;} + ; + +typename: TYPENAME + ; + +nonempty_typelist + : type + { $$ = (struct type **) malloc (sizeof (struct type *) * 2); + $<ivec>$[0] = 1; /* Number of types in vector */ + $$[1] = $1; + } + | nonempty_typelist ',' type + { int len = sizeof (struct type *) * (++($<ivec>1[0]) + 1); + $$ = (struct type **) realloc ((char *) $1, len); + $$[$<ivec>$[0]] = $3; + } + ; + +name : NAME + { $$ = $1.stoken; } + | TYPENAME + { $$ = $1.stoken; } + | NAME_OR_INT + { $$ = $1.stoken; } + ; + +name_not_typename : NAME +/* These would be useful if name_not_typename was useful, but it is just + a fake for "variable", so these cause reduce/reduce conflicts because + the parser can't tell whether NAME_OR_INT is a name_not_typename (=variable, + =exp) or just an exp. If name_not_typename was ever used in an lvalue + context where only a name could occur, this might be useful. + | NAME_OR_INT + */ + ; + +%% + +/* Take care of parsing a number (anything that starts with a digit). + Set yylval and return the token type; update lexptr. + LEN is the number of characters in it. */ + +/*** Needs some error checking for the float case ***/ + +static int +parse_number (p, len, parsed_float, putithere) + register char *p; + register int len; + int parsed_float; + YYSTYPE *putithere; +{ + register LONGEST n = 0; + register LONGEST prevn = 0; + register int i; + register int c; + register int base = input_radix; + int unsigned_p = 0; + int long_p = 0; + unsigned LONGEST high_bit; + struct type *signed_type; + struct type *unsigned_type; + + if (parsed_float) + { + /* It's a float since it contains a point or an exponent. */ + putithere->dval = atof (p); + return FLOAT; + } + + /* Handle base-switching prefixes 0x, 0t, 0d, 0 */ + if (p[0] == '0') + switch (p[1]) + { + case 'x': + case 'X': + if (len >= 3) + { + p += 2; + base = 16; + len -= 2; + } + break; + + case 't': + case 'T': + case 'd': + case 'D': + if (len >= 3) + { + p += 2; + base = 10; + len -= 2; + } + break; + + default: + base = 8; + break; + } + + while (len-- > 0) + { + c = *p++; + if (c >= 'A' && c <= 'Z') + c += 'a' - 'A'; + if (c != 'l' && c != 'u') + n *= base; + if (c >= '0' && c <= '9') + n += i = c - '0'; + else + { + if (base > 10 && c >= 'a' && c <= 'f') + n += i = c - 'a' + 10; + else if (len == 0 && c == 'l') + long_p = 1; + else if (len == 0 && c == 'u') + unsigned_p = 1; + else + return ERROR; /* Char not a digit */ + } + if (i >= base) + return ERROR; /* Invalid digit in this base */ + + /* Portably test for overflow (only works for nonzero values, so make + a second check for zero). */ + if ((prevn >= n) && n != 0) + unsigned_p=1; /* Try something unsigned */ + /* If range checking enabled, portably test for unsigned overflow. */ + if (RANGE_CHECK && n != 0) + { + if ((unsigned_p && (unsigned)prevn >= (unsigned)n)) + range_error("Overflow on numeric constant."); + } + prevn = n; + } + + /* If the number is too big to be an int, or it's got an l suffix + then it's a long. Work out if this has to be a long by + shifting right and and seeing if anything remains, and the + target int size is different to the target long size. + + In the expression below, we could have tested + (n >> TARGET_INT_BIT) + to see if it was zero, + but too many compilers warn about that, when ints and longs + are the same size. So we shift it twice, with fewer bits + each time, for the same result. */ + + if ((TARGET_INT_BIT != TARGET_LONG_BIT + && ((n >> 2) >> (TARGET_INT_BIT-2))) /* Avoid shift warning */ + || long_p) + { + high_bit = ((unsigned LONGEST)1) << (TARGET_LONG_BIT-1); + unsigned_type = builtin_type_unsigned_long; + signed_type = builtin_type_long; + } + else + { + high_bit = ((unsigned LONGEST)1) << (TARGET_INT_BIT-1); + unsigned_type = builtin_type_unsigned_int; + signed_type = builtin_type_int; + } + + putithere->typed_val.val = n; + + /* If the high bit of the worked out type is set then this number + has to be unsigned. */ + + if (unsigned_p || (n & high_bit)) + putithere->typed_val.type = unsigned_type; + else + putithere->typed_val.type = signed_type; + + return INT; +} + +struct token +{ + char *operator; + int token; + enum exp_opcode opcode; +}; + +static const struct token dot_ops[] = +{ + { ".and.", BOOL_AND, BINOP_END }, + { ".AND.", BOOL_AND, BINOP_END }, + { ".or.", BOOL_OR, BINOP_END }, + { ".OR.", BOOL_OR, BINOP_END }, + { ".not.", BOOL_NOT, BINOP_END }, + { ".NOT.", BOOL_NOT, BINOP_END }, + { ".eq.", EQUAL, BINOP_END }, + { ".EQ.", EQUAL, BINOP_END }, + { ".eqv.", EQUAL, BINOP_END }, + { ".NEQV.", NOTEQUAL, BINOP_END }, + { ".neqv.", NOTEQUAL, BINOP_END }, + { ".EQV.", EQUAL, BINOP_END }, + { ".ne.", NOTEQUAL, BINOP_END }, + { ".NE.", NOTEQUAL, BINOP_END }, + { ".le.", LEQ, BINOP_END }, + { ".LE.", LEQ, BINOP_END }, + { ".ge.", GEQ, BINOP_END }, + { ".GE.", GEQ, BINOP_END }, + { ".gt.", GREATERTHAN, BINOP_END }, + { ".GT.", GREATERTHAN, BINOP_END }, + { ".lt.", LESSTHAN, BINOP_END }, + { ".LT.", LESSTHAN, BINOP_END }, + { NULL, 0, 0 } +}; + +struct f77_boolean_val +{ + char *name; + int value; +}; + +static const struct f77_boolean_val boolean_values[] = +{ + { ".true.", 1 }, + { ".TRUE.", 1 }, + { ".false.", 0 }, + { ".FALSE.", 0 }, + { NULL, 0 } +}; + +static const struct token f77_keywords[] = +{ + { "complex_16", COMPLEX_S16_KEYWORD, BINOP_END }, + { "complex_32", COMPLEX_S32_KEYWORD, BINOP_END }, + { "character", CHARACTER, BINOP_END }, + { "integer_2", INT_S2_KEYWORD, BINOP_END }, + { "logical_1", LOGICAL_S1_KEYWORD, BINOP_END }, + { "logical_2", LOGICAL_S2_KEYWORD, BINOP_END }, + { "complex_8", COMPLEX_S8_KEYWORD, BINOP_END }, + { "integer", INT_KEYWORD, BINOP_END }, + { "logical", LOGICAL_KEYWORD, BINOP_END }, + { "real_16", REAL_S16_KEYWORD, BINOP_END }, + { "complex", COMPLEX_S8_KEYWORD, BINOP_END }, + { "sizeof", SIZEOF, BINOP_END }, + { "real_8", REAL_S8_KEYWORD, BINOP_END }, + { "real", REAL_KEYWORD, BINOP_END }, + { NULL, 0, 0 } +}; + +/* Implementation of a dynamically expandable buffer for processing input + characters acquired through lexptr and building a value to return in + yylval. Ripped off from ch-exp.y */ + +static char *tempbuf; /* Current buffer contents */ +static int tempbufsize; /* Size of allocated buffer */ +static int tempbufindex; /* Current index into buffer */ + +#define GROWBY_MIN_SIZE 64 /* Minimum amount to grow buffer by */ + +#define CHECKBUF(size) \ + do { \ + if (tempbufindex + (size) >= tempbufsize) \ + { \ + growbuf_by_size (size); \ + } \ + } while (0); + + +/* Grow the static temp buffer if necessary, including allocating the first one + on demand. */ + +static void +growbuf_by_size (count) + int count; +{ + int growby; + + growby = max (count, GROWBY_MIN_SIZE); + tempbufsize += growby; + if (tempbuf == NULL) + tempbuf = (char *) malloc (tempbufsize); + else + tempbuf = (char *) realloc (tempbuf, tempbufsize); +} + +/* Blatantly ripped off from ch-exp.y. This routine recognizes F77 + string-literals. + + Recognize a string literal. A string literal is a nonzero sequence + of characters enclosed in matching single quotes, except that + a single character inside single quotes is a character literal, which + we reject as a string literal. To embed the terminator character inside + a string, it is simply doubled (I.E. 'this''is''one''string') */ + +static int +match_string_literal () +{ + char *tokptr = lexptr; + + for (tempbufindex = 0, tokptr++; *tokptr != '\0'; tokptr++) + { + CHECKBUF (1); + if (*tokptr == *lexptr) + { + if (*(tokptr + 1) == *lexptr) + tokptr++; + else + break; + } + tempbuf[tempbufindex++] = *tokptr; + } + if (*tokptr == '\0' /* no terminator */ + || tempbufindex == 0) /* no string */ + return 0; + else + { + tempbuf[tempbufindex] = '\0'; + yylval.sval.ptr = tempbuf; + yylval.sval.length = tempbufindex; + lexptr = ++tokptr; + return STRING_LITERAL; + } +} + +/* Read one token, getting characters through lexptr. */ + +static int +yylex () +{ + int c; + int namelen; + unsigned int i,token; + char *tokstart; + char *tokptr; + int tempbufindex; + static char *tempbuf; + static int tempbufsize; + + retry: + + tokstart = lexptr; + + /* First of all, let us make sure we are not dealing with the + special tokens .true. and .false. which evaluate to 1 and 0. */ + + if (*lexptr == '.') + { + for (i=0;boolean_values[i].name != NULL;i++) + { + if STREQN(tokstart,boolean_values[i].name, + strlen(boolean_values[i].name)) + { + lexptr += strlen(boolean_values[i].name); + yylval.lval = boolean_values[i].value; + return (BOOLEAN_LITERAL); + } + } + } + + /* See if it is a special .foo. operator */ + + for (i = 0; dot_ops[i].operator != NULL; i++) + if (STREQN(tokstart, dot_ops[i].operator, + strlen(dot_ops[i].operator))) + { + lexptr += strlen(dot_ops[i].operator); + yylval.opcode = dot_ops[i].opcode; + return dot_ops[i].token; + } + + switch (c = *tokstart) + { + case 0: + return 0; + + case ' ': + case '\t': + case '\n': + lexptr++; + goto retry; + + case '\'': + token = match_string_literal (); + if (token != 0) + return (token); + break; + + case '(': + paren_depth++; + lexptr++; + return c; + + case ')': + if (paren_depth == 0) + return 0; + paren_depth--; + lexptr++; + return c; + + case ',': + if (comma_terminates && paren_depth == 0) + return 0; + lexptr++; + return c; + + case '.': + /* Might be a floating point number. */ + if (lexptr[1] < '0' || lexptr[1] > '9') + goto symbol; /* Nope, must be a symbol. */ + /* FALL THRU into number case. */ + + case '0': + case '1': + case '2': + case '3': + case '4': + case '5': + case '6': + case '7': + case '8': + case '9': + { + /* It's a number. */ + int got_dot = 0, got_e = 0, got_d = 0, toktype; + register char *p = tokstart; + int hex = input_radix > 10; + + if (c == '0' && (p[1] == 'x' || p[1] == 'X')) + { + p += 2; + hex = 1; + } + else if (c == '0' && (p[1]=='t' || p[1]=='T' || p[1]=='d' || p[1]=='D')) + { + p += 2; + hex = 0; + } + + for (;; ++p) + { + if (!hex && !got_e && (*p == 'e' || *p == 'E')) + got_dot = got_e = 1; + else if (!hex && !got_e && (*p == 'd' || *p == 'D')) + got_dot = got_d = 1; + else if (!hex && !got_dot && *p == '.') + got_dot = 1; + else if ((got_e && (p[-1] == 'e' || p[-1] == 'E') + || got_d && (p[-1] == 'd' || p[-1] == 'D')) + && (*p == '-' || *p == '+')) + /* This is the sign of the exponent, not the end of the + number. */ + continue; + /* We will take any letters or digits. parse_number will + complain if past the radix, or if L or U are not final. */ + else if ((*p < '0' || *p > '9') + && ((*p < 'a' || *p > 'z') + && (*p < 'A' || *p > 'Z'))) + break; + } + toktype = parse_number (tokstart, p - tokstart, got_dot|got_e|got_d, + &yylval); + if (toktype == ERROR) + { + char *err_copy = (char *) alloca (p - tokstart + 1); + + memcpy (err_copy, tokstart, p - tokstart); + err_copy[p - tokstart] = 0; + error ("Invalid number \"%s\".", err_copy); + } + lexptr = p; + return toktype; + } + + case '+': + case '-': + case '*': + case '/': + case '%': + case '|': + case '&': + case '^': + case '~': + case '!': + case '@': + case '<': + case '>': + case '[': + case ']': + case '?': + case ':': + case '=': + case '{': + case '}': + symbol: + lexptr++; + return c; + } + + if (!(c == '_' || c == '$' + || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z'))) + /* We must have come across a bad character (e.g. ';'). */ + error ("Invalid character '%c' in expression.", c); + + namelen = 0; + for (c = tokstart[namelen]; + (c == '_' || c == '$' || (c >= '0' && c <= '9') + || (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z')); + c = tokstart[++namelen]); + + /* The token "if" terminates the expression and is NOT + removed from the input stream. */ + + if (namelen == 2 && tokstart[0] == 'i' && tokstart[1] == 'f') + return 0; + + lexptr += namelen; + + /* Handle the tokens $digits; also $ (short for $0) and $$ (short for $$1) + and $$digits (equivalent to $<-digits> if you could type that). + Make token type LAST, and put the number (the digits) in yylval. */ + + tryname: + if (*tokstart == '$') + { + register int negate = 0; + + c = 1; + /* Double dollar means negate the number and add -1 as well. + Thus $$ alone means -1. */ + if (namelen >= 2 && tokstart[1] == '$') + { + negate = 1; + c = 2; + } + if (c == namelen) + { + /* Just dollars (one or two) */ + yylval.lval = - negate; + return LAST; + } + /* Is the rest of the token digits? */ + for (; c < namelen; c++) + if (!(tokstart[c] >= '0' && tokstart[c] <= '9')) + break; + if (c == namelen) + { + yylval.lval = atoi (tokstart + 1 + negate); + if (negate) + yylval.lval = - yylval.lval; + return LAST; + } + } + + /* Handle tokens that refer to machine registers: + $ followed by a register name. */ + + if (*tokstart == '$') { + for (c = 0; c < NUM_REGS; c++) + if (namelen - 1 == strlen (reg_names[c]) + && STREQN (tokstart + 1, reg_names[c], namelen - 1)) + { + yylval.lval = c; + return REGNAME; + } + for (c = 0; c < num_std_regs; c++) + if (namelen - 1 == strlen (std_regs[c].name) + && STREQN (tokstart + 1, std_regs[c].name, namelen - 1)) + { + yylval.lval = std_regs[c].regnum; + return REGNAME; + } + } + /* Catch specific keywords. */ + + for (i = 0; f77_keywords[i].operator != NULL; i++) + if (STREQN(tokstart, f77_keywords[i].operator, + strlen(f77_keywords[i].operator))) + { + /* lexptr += strlen(f77_keywords[i].operator); */ + yylval.opcode = f77_keywords[i].opcode; + return f77_keywords[i].token; + } + + yylval.sval.ptr = tokstart; + yylval.sval.length = namelen; + + /* Any other names starting in $ are debugger internal variables. */ + + if (*tokstart == '$') + { + yylval.ivar = lookup_internalvar (copy_name (yylval.sval) + 1); + return VARIABLE; + } + + /* Use token-type TYPENAME for symbols that happen to be defined + currently as names of types; NAME for other symbols. + The caller is not constrained to care about the distinction. */ + { + char *tmp = copy_name (yylval.sval); + struct symbol *sym; + int is_a_field_of_this = 0; + int hextype; + + sym = lookup_symbol (tmp, expression_context_block, + VAR_NAMESPACE, + current_language->la_language == language_cplus + ? &is_a_field_of_this : NULL, + NULL); + if (sym && SYMBOL_CLASS (sym) == LOC_TYPEDEF) + { + yylval.tsym.type = SYMBOL_TYPE (sym); + return TYPENAME; + } + if ((yylval.tsym.type = lookup_primitive_typename (tmp)) != 0) + return TYPENAME; + + /* Input names that aren't symbols but ARE valid hex numbers, + when the input radix permits them, can be names or numbers + depending on the parse. Note we support radixes > 16 here. */ + if (!sym + && ((tokstart[0] >= 'a' && tokstart[0] < 'a' + input_radix - 10) + || (tokstart[0] >= 'A' && tokstart[0] < 'A' + input_radix - 10))) + { + YYSTYPE newlval; /* Its value is ignored. */ + hextype = parse_number (tokstart, namelen, 0, &newlval); + if (hextype == INT) + { + yylval.ssym.sym = sym; + yylval.ssym.is_a_field_of_this = is_a_field_of_this; + return NAME_OR_INT; + } + } + + /* Any other kind of symbol */ + yylval.ssym.sym = sym; + yylval.ssym.is_a_field_of_this = is_a_field_of_this; + return NAME; + } +} + +void +yyerror (msg) + char *msg; +{ + error ("A %s in expression, near `%s'.", (msg ? msg : "error"), lexptr); +} diff --git a/gdb/f-lang.c b/gdb/f-lang.c new file mode 100644 index 0000000..f9d55b7 --- /dev/null +++ b/gdb/f-lang.c @@ -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; +} diff --git a/gdb/f-lang.h b/gdb/f-lang.h new file mode 100644 index 0000000..9611366 --- /dev/null +++ b/gdb/f-lang.h @@ -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" diff --git a/gdb/f-typeprint.c b/gdb/f-typeprint.c new file mode 100644 index 0000000..3540f48 --- /dev/null +++ b/gdb/f-typeprint.c @@ -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; + } +} diff --git a/gdb/f-valprint.c b/gdb/f-valprint.c new file mode 100644 index 0000000..0e0cdbc --- /dev/null +++ b/gdb/f-valprint.c @@ -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."); +} diff --git a/gdb/gdbtypes.c b/gdb/gdbtypes.c index b891237..a87d9a1 100644 --- a/gdb/gdbtypes.c +++ b/gdb/gdbtypes.c @@ -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 diff --git a/gdb/gdbtypes.h b/gdb/gdbtypes.h index 62fe1ab..918e1a6 100644 --- a/gdb/gdbtypes.h +++ b/gdb/gdbtypes.h @@ -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) \ diff --git a/gdb/language.c b/gdb/language.c index c06decb..f27512c 100644 --- a/gdb/language.c +++ b/gdb/language.c @@ -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); diff --git a/gdb/language.h b/gdb/language.h index e9a2eff..7ab04db 100644 --- a/gdb/language.h +++ b/gdb/language.h @@ -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. diff --git a/gdb/parse.c b/gdb/parse.c index 8c387c8..a16be75 100644 --- a/gdb/parse.c +++ b/gdb/parse.c @@ -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; diff --git a/gdb/valops.c b/gdb/valops.c index 24f2c78..06f3527 100644 --- a/gdb/valops.c +++ b/gdb/valops.c @@ -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 CORE_ADDR -find_function_addr PARAMS ((value, struct type **)); +static int typecmp PARAMS ((int staticp, struct type *t1[], value_ptr t2[])); -static CORE_ADDR -value_push PARAMS ((CORE_ADDR, value)); +static CORE_ADDR find_function_addr PARAMS ((value_ptr, struct type **)); -static CORE_ADDR -value_arg_push PARAMS ((CORE_ADDR, value)); +static CORE_ADDR value_push PARAMS ((CORE_ADDR, value_ptr)); -static value -search_struct_field PARAMS ((char *, value, int, struct type *, int)); +static CORE_ADDR value_arg_push PARAMS ((CORE_ADDR, value_ptr)); -static value -search_struct_method PARAMS ((char *, value *, value *, int, int *, - struct type *)); +static value_ptr search_struct_field PARAMS ((char *, value_ptr, int, + struct type *, int)); -static int -check_field_in PARAMS ((struct type *, const char *)); +static value_ptr search_struct_method PARAMS ((char *, value_ptr *, + value_ptr *, + int, int *, struct type *)); -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; +} diff --git a/gdb/value.h b/gdb/value.h index 6982258..3c4a047 100644 --- a/gdb/value.h +++ b/gdb/value.h @@ -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) */ |