(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 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
--- /dev/null
+/* 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 '('
+
+\f
+%%
+
+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);
+}
--- /dev/null
+/* 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);
+}
+
+\f
+/* 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 }
+};
+\f
+/* 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;
+}
--- /dev/null
+/* 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"
--- /dev/null
+/* 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));
+
+\f
+/* 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;
+ }
+}
--- /dev/null
+/* 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);
+}
+
+\f
+/* 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.");
+}
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
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,
/* 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
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
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
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) \
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);
#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.
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;
/* 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;
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;
/* 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;
/* 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));
\f
/* Allocate NBYTES of space in the inferior using the inferior's malloc
and return a value that is a pointer to the allocated space. */
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. */
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;
/* 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;
&& 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);
/* 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;
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));
/* 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;
int
value_fetch_lazy (val)
- register value val;
+ register value_ptr val;
{
CORE_ADDR addr = VALUE_ADDRESS (val) + VALUE_OFFSET (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;
/* 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 '@'.");
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)
the coercion to pointer type.
*/
-value
+value_ptr
value_coerce_array (arg1)
- value arg1;
+ value_ptr arg1;
{
register struct type *type;
/* 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)
/* 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)
/* 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;
}
/* 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);
static CORE_ADDR
value_push (sp, arg)
register CORE_ADDR sp;
- value arg;
+ value_ptr arg;
{
register int len = TYPE_LENGTH (VALUE_TYPE (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;
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));
}
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);
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;
#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. */
}
}
#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.");
}
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;
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;
typecmp (staticp, t1, t2)
int staticp;
struct type *t1[];
- value t2[];
+ value_ptr t2[];
{
int i;
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;
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);
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. */
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);
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];
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--;
}
}
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;
}
return v;
}
}
- if (name_matched) return (value) -1;
+ if (name_matched) return (value_ptr) -1;
else return NULL;
}
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);
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)
{
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;
}
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);
}
int
check_field (arg1, name)
- register value arg1;
+ register value_ptr arg1;
const char *name;
{
register struct type *t;
"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;
{
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)
}
for (i = TYPE_N_BASECLASSES (t) - 1; i >= 0; i--)
{
- value v;
+ value_ptr v;
int base_offset;
if (BASETYPE_VIA_VIRTUAL (t, i))
/* 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;
{
struct block *b;
int i;
static const char funny_this[] = "this";
- value this;
+ value_ptr this;
if (selected_frame == 0)
if (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;
+}
#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) \
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));
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) */
projects / external / binutils.git / commitdiff