119370Spst/* Fortran language support routines for GDB, the GNU debugger. 2130803Smarcel Copyright 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 2004 398944Sobrien Free Software Foundation, Inc. 419370Spst Contributed by Motorola. Adapted from the C parser by Farooq Butt 519370Spst (fmbutt@engage.sps.mot.com). 619370Spst 798944Sobrien This file is part of GDB. 819370Spst 998944Sobrien This program is free software; you can redistribute it and/or modify 1098944Sobrien it under the terms of the GNU General Public License as published by 1198944Sobrien the Free Software Foundation; either version 2 of the License, or 1298944Sobrien (at your option) any later version. 1319370Spst 1498944Sobrien This program is distributed in the hope that it will be useful, 1598944Sobrien but WITHOUT ANY WARRANTY; without even the implied warranty of 1698944Sobrien MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 1798944Sobrien GNU General Public License for more details. 1819370Spst 1998944Sobrien You should have received a copy of the GNU General Public License 2098944Sobrien along with this program; if not, write to the Free Software 2198944Sobrien Foundation, Inc., 59 Temple Place - Suite 330, 2298944Sobrien Boston, MA 02111-1307, USA. */ 2319370Spst 2419370Spst#include "defs.h" 2519370Spst#include "gdb_string.h" 2619370Spst#include "symtab.h" 2719370Spst#include "gdbtypes.h" 2819370Spst#include "expression.h" 2919370Spst#include "parser-defs.h" 3019370Spst#include "language.h" 3119370Spst#include "f-lang.h" 3298944Sobrien#include "valprint.h" 33130803Smarcel#include "value.h" 3419370Spst 3519370Spst/* The built-in types of F77. FIXME: integer*4 is missing, plain 3619370Spst logical is missing (builtin_type_logical is logical*4). */ 3719370Spst 3819370Spststruct type *builtin_type_f_character; 3919370Spststruct type *builtin_type_f_logical; 4019370Spststruct type *builtin_type_f_logical_s1; 4119370Spststruct type *builtin_type_f_logical_s2; 4298944Sobrienstruct type *builtin_type_f_integer; 4319370Spststruct type *builtin_type_f_integer_s2; 4419370Spststruct type *builtin_type_f_real; 4519370Spststruct type *builtin_type_f_real_s8; 4619370Spststruct type *builtin_type_f_real_s16; 4719370Spststruct type *builtin_type_f_complex_s8; 4819370Spststruct type *builtin_type_f_complex_s16; 4919370Spststruct type *builtin_type_f_complex_s32; 5019370Spststruct type *builtin_type_f_void; 5119370Spst 5246283Sdfr/* Following is dubious stuff that had been in the xcoff reader. */ 5346283Sdfr 5446283Sdfrstruct saved_fcn 5598944Sobrien { 5698944Sobrien long line_offset; /* Line offset for function */ 5798944Sobrien struct saved_fcn *next; 5898944Sobrien }; 5946283Sdfr 6046283Sdfr 6198944Sobrienstruct saved_bf_symnum 6298944Sobrien { 6398944Sobrien long symnum_fcn; /* Symnum of function (i.e. .function directive) */ 6498944Sobrien long symnum_bf; /* Symnum of .bf for this function */ 6598944Sobrien struct saved_bf_symnum *next; 6698944Sobrien }; 6746283Sdfr 6898944Sobrientypedef struct saved_fcn SAVED_FUNCTION, *SAVED_FUNCTION_PTR; 6998944Sobrientypedef struct saved_bf_symnum SAVED_BF, *SAVED_BF_PTR; 7046283Sdfr 7146283Sdfr/* Local functions */ 7246283Sdfr 7398944Sobrienextern void _initialize_f_language (void); 7446283Sdfr#if 0 7598944Sobrienstatic void clear_function_list (void); 7698944Sobrienstatic long get_bf_for_fcn (long); 7798944Sobrienstatic void clear_bf_list (void); 7898944Sobrienstatic void patch_all_commons_by_name (char *, CORE_ADDR, int); 7998944Sobrienstatic SAVED_F77_COMMON_PTR find_first_common_named (char *); 8098944Sobrienstatic void add_common_entry (struct symbol *); 8198944Sobrienstatic void add_common_block (char *, CORE_ADDR, int, char *); 8298944Sobrienstatic SAVED_FUNCTION *allocate_saved_function_node (void); 8398944Sobrienstatic SAVED_BF_PTR allocate_saved_bf_node (void); 8498944Sobrienstatic COMMON_ENTRY_PTR allocate_common_entry_node (void); 8598944Sobrienstatic SAVED_F77_COMMON_PTR allocate_saved_f77_common_node (void); 8698944Sobrienstatic void patch_common_entries (SAVED_F77_COMMON_PTR, CORE_ADDR, int); 8746283Sdfr#endif 8846283Sdfr 8998944Sobrienstatic struct type *f_create_fundamental_type (struct objfile *, int); 9098944Sobrienstatic void f_printstr (struct ui_file * stream, char *string, 9198944Sobrien unsigned int length, int width, 9298944Sobrien int force_ellipses); 9398944Sobrienstatic void f_printchar (int c, struct ui_file * stream); 9498944Sobrienstatic void f_emit_char (int c, struct ui_file * stream, int quoter); 9546283Sdfr 9619370Spst/* Print the character C on STREAM as part of the contents of a literal 9719370Spst string whose delimiter is QUOTER. Note that that format for printing 9819370Spst characters and strings is language specific. 9919370Spst FIXME: This is a copy of the same function from c-exp.y. It should 10019370Spst be replaced with a true F77 version. */ 10119370Spst 10219370Spststatic void 103130803Smarcelf_emit_char (int c, struct ui_file *stream, int quoter) 10419370Spst{ 10519370Spst c &= 0xFF; /* Avoid sign bit follies */ 10698944Sobrien 10719370Spst if (PRINT_LITERAL_FORM (c)) 10819370Spst { 10919370Spst if (c == '\\' || c == quoter) 11019370Spst fputs_filtered ("\\", stream); 11119370Spst fprintf_filtered (stream, "%c", c); 11219370Spst } 11319370Spst else 11419370Spst { 11519370Spst switch (c) 11619370Spst { 11719370Spst case '\n': 11819370Spst fputs_filtered ("\\n", stream); 11919370Spst break; 12019370Spst case '\b': 12119370Spst fputs_filtered ("\\b", stream); 12219370Spst break; 12319370Spst case '\t': 12419370Spst fputs_filtered ("\\t", stream); 12519370Spst break; 12619370Spst case '\f': 12719370Spst fputs_filtered ("\\f", stream); 12819370Spst break; 12919370Spst case '\r': 13019370Spst fputs_filtered ("\\r", stream); 13119370Spst break; 13219370Spst case '\033': 13319370Spst fputs_filtered ("\\e", stream); 13419370Spst break; 13519370Spst case '\007': 13619370Spst fputs_filtered ("\\a", stream); 13719370Spst break; 13819370Spst default: 13919370Spst fprintf_filtered (stream, "\\%.3o", (unsigned int) c); 14019370Spst break; 14119370Spst } 14219370Spst } 14319370Spst} 14419370Spst 14519370Spst/* FIXME: This is a copy of the same function from c-exp.y. It should 14619370Spst be replaced with a true F77version. */ 14719370Spst 14819370Spststatic void 14998944Sobrienf_printchar (int c, struct ui_file *stream) 15019370Spst{ 15119370Spst fputs_filtered ("'", stream); 15246283Sdfr LA_EMIT_CHAR (c, stream, '\''); 15319370Spst fputs_filtered ("'", stream); 15419370Spst} 15519370Spst 15619370Spst/* Print the character string STRING, printing at most LENGTH characters. 15719370Spst Printing stops early if the number hits print_max; repeat counts 15819370Spst are printed as appropriate. Print ellipses at the end if we 15919370Spst had to stop before printing LENGTH characters, or if FORCE_ELLIPSES. 16019370Spst FIXME: This is a copy of the same function from c-exp.y. It should 16119370Spst be replaced with a true F77 version. */ 16219370Spst 16319370Spststatic void 16498944Sobrienf_printstr (struct ui_file *stream, char *string, unsigned int length, 16598944Sobrien int width, int force_ellipses) 16619370Spst{ 167130803Smarcel unsigned int i; 16819370Spst unsigned int things_printed = 0; 16919370Spst int in_quotes = 0; 17019370Spst int need_comma = 0; 17198944Sobrien 17219370Spst if (length == 0) 17319370Spst { 17446283Sdfr fputs_filtered ("''", gdb_stdout); 17519370Spst return; 17619370Spst } 17798944Sobrien 17819370Spst for (i = 0; i < length && things_printed < print_max; ++i) 17919370Spst { 18019370Spst /* Position of the character we are examining 18198944Sobrien to see whether it is repeated. */ 18219370Spst unsigned int rep1; 18319370Spst /* Number of repetitions we have detected so far. */ 18419370Spst unsigned int reps; 18598944Sobrien 18619370Spst QUIT; 18798944Sobrien 18819370Spst if (need_comma) 18919370Spst { 19019370Spst fputs_filtered (", ", stream); 19119370Spst need_comma = 0; 19219370Spst } 19398944Sobrien 19419370Spst rep1 = i + 1; 19519370Spst reps = 1; 19619370Spst while (rep1 < length && string[rep1] == string[i]) 19719370Spst { 19819370Spst ++rep1; 19919370Spst ++reps; 20019370Spst } 20198944Sobrien 20219370Spst if (reps > repeat_count_threshold) 20319370Spst { 20419370Spst if (in_quotes) 20519370Spst { 20619370Spst if (inspect_it) 20719370Spst fputs_filtered ("\\', ", stream); 20819370Spst else 20919370Spst fputs_filtered ("', ", stream); 21019370Spst in_quotes = 0; 21119370Spst } 21219370Spst f_printchar (string[i], stream); 21319370Spst fprintf_filtered (stream, " <repeats %u times>", reps); 21419370Spst i = rep1 - 1; 21519370Spst things_printed += repeat_count_threshold; 21619370Spst need_comma = 1; 21719370Spst } 21819370Spst else 21919370Spst { 22019370Spst if (!in_quotes) 22119370Spst { 22219370Spst if (inspect_it) 22319370Spst fputs_filtered ("\\'", stream); 22419370Spst else 22519370Spst fputs_filtered ("'", stream); 22619370Spst in_quotes = 1; 22719370Spst } 22846283Sdfr LA_EMIT_CHAR (string[i], stream, '"'); 22919370Spst ++things_printed; 23019370Spst } 23119370Spst } 23298944Sobrien 23319370Spst /* Terminate the quotes if necessary. */ 23419370Spst if (in_quotes) 23519370Spst { 23619370Spst if (inspect_it) 23719370Spst fputs_filtered ("\\'", stream); 23819370Spst else 23919370Spst fputs_filtered ("'", stream); 24019370Spst } 24198944Sobrien 24219370Spst if (force_ellipses || i < length) 24319370Spst fputs_filtered ("...", stream); 24419370Spst} 24519370Spst 24619370Spst/* FIXME: This is a copy of c_create_fundamental_type(), before 24719370Spst all the non-C types were stripped from it. Needs to be fixed 24819370Spst by an experienced F77 programmer. */ 24919370Spst 25019370Spststatic struct type * 25198944Sobrienf_create_fundamental_type (struct objfile *objfile, int typeid) 25219370Spst{ 253130803Smarcel struct type *type = NULL; 25498944Sobrien 25519370Spst switch (typeid) 25619370Spst { 25719370Spst case FT_VOID: 25819370Spst type = init_type (TYPE_CODE_VOID, 25919370Spst TARGET_CHAR_BIT / TARGET_CHAR_BIT, 26019370Spst 0, "VOID", objfile); 26119370Spst break; 26219370Spst case FT_BOOLEAN: 26319370Spst type = init_type (TYPE_CODE_BOOL, 26419370Spst TARGET_CHAR_BIT / TARGET_CHAR_BIT, 26519370Spst TYPE_FLAG_UNSIGNED, "boolean", objfile); 26619370Spst break; 26719370Spst case FT_STRING: 26819370Spst type = init_type (TYPE_CODE_STRING, 26919370Spst TARGET_CHAR_BIT / TARGET_CHAR_BIT, 27019370Spst 0, "string", objfile); 27119370Spst break; 27219370Spst case FT_CHAR: 27319370Spst type = init_type (TYPE_CODE_INT, 27419370Spst TARGET_CHAR_BIT / TARGET_CHAR_BIT, 27519370Spst 0, "character", objfile); 27619370Spst break; 27719370Spst case FT_SIGNED_CHAR: 27819370Spst type = init_type (TYPE_CODE_INT, 27919370Spst TARGET_CHAR_BIT / TARGET_CHAR_BIT, 28019370Spst 0, "integer*1", objfile); 28119370Spst break; 28219370Spst case FT_UNSIGNED_CHAR: 28319370Spst type = init_type (TYPE_CODE_BOOL, 28419370Spst TARGET_CHAR_BIT / TARGET_CHAR_BIT, 28519370Spst TYPE_FLAG_UNSIGNED, "logical*1", objfile); 28619370Spst break; 28719370Spst case FT_SHORT: 28819370Spst type = init_type (TYPE_CODE_INT, 28919370Spst TARGET_SHORT_BIT / TARGET_CHAR_BIT, 29019370Spst 0, "integer*2", objfile); 29119370Spst break; 29219370Spst case FT_SIGNED_SHORT: 29319370Spst type = init_type (TYPE_CODE_INT, 29419370Spst TARGET_SHORT_BIT / TARGET_CHAR_BIT, 29519370Spst 0, "short", objfile); /* FIXME-fnf */ 29619370Spst break; 29719370Spst case FT_UNSIGNED_SHORT: 29819370Spst type = init_type (TYPE_CODE_BOOL, 29919370Spst TARGET_SHORT_BIT / TARGET_CHAR_BIT, 30019370Spst TYPE_FLAG_UNSIGNED, "logical*2", objfile); 30119370Spst break; 30219370Spst case FT_INTEGER: 30319370Spst type = init_type (TYPE_CODE_INT, 30419370Spst TARGET_INT_BIT / TARGET_CHAR_BIT, 30519370Spst 0, "integer*4", objfile); 30619370Spst break; 30719370Spst case FT_SIGNED_INTEGER: 30819370Spst type = init_type (TYPE_CODE_INT, 30919370Spst TARGET_INT_BIT / TARGET_CHAR_BIT, 31098944Sobrien 0, "integer", objfile); /* FIXME -fnf */ 31119370Spst break; 31219370Spst case FT_UNSIGNED_INTEGER: 31398944Sobrien type = init_type (TYPE_CODE_BOOL, 31419370Spst TARGET_INT_BIT / TARGET_CHAR_BIT, 31519370Spst TYPE_FLAG_UNSIGNED, "logical*4", objfile); 31619370Spst break; 31719370Spst case FT_FIXED_DECIMAL: 31819370Spst type = init_type (TYPE_CODE_INT, 31919370Spst TARGET_INT_BIT / TARGET_CHAR_BIT, 32019370Spst 0, "fixed decimal", objfile); 32119370Spst break; 32219370Spst case FT_LONG: 32319370Spst type = init_type (TYPE_CODE_INT, 32419370Spst TARGET_LONG_BIT / TARGET_CHAR_BIT, 32519370Spst 0, "long", objfile); 32619370Spst break; 32719370Spst case FT_SIGNED_LONG: 32819370Spst type = init_type (TYPE_CODE_INT, 32919370Spst TARGET_LONG_BIT / TARGET_CHAR_BIT, 33098944Sobrien 0, "long", objfile); /* FIXME -fnf */ 33119370Spst break; 33219370Spst case FT_UNSIGNED_LONG: 33319370Spst type = init_type (TYPE_CODE_INT, 33419370Spst TARGET_LONG_BIT / TARGET_CHAR_BIT, 33519370Spst TYPE_FLAG_UNSIGNED, "unsigned long", objfile); 33619370Spst break; 33719370Spst case FT_LONG_LONG: 33819370Spst type = init_type (TYPE_CODE_INT, 33919370Spst TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT, 34019370Spst 0, "long long", objfile); 34119370Spst break; 34219370Spst case FT_SIGNED_LONG_LONG: 34319370Spst type = init_type (TYPE_CODE_INT, 34419370Spst TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT, 34519370Spst 0, "signed long long", objfile); 34619370Spst break; 34719370Spst case FT_UNSIGNED_LONG_LONG: 34819370Spst type = init_type (TYPE_CODE_INT, 34919370Spst TARGET_LONG_LONG_BIT / TARGET_CHAR_BIT, 35019370Spst TYPE_FLAG_UNSIGNED, "unsigned long long", objfile); 35119370Spst break; 35219370Spst case FT_FLOAT: 35319370Spst type = init_type (TYPE_CODE_FLT, 35419370Spst TARGET_FLOAT_BIT / TARGET_CHAR_BIT, 35519370Spst 0, "real", objfile); 35619370Spst break; 35719370Spst case FT_DBL_PREC_FLOAT: 35819370Spst type = init_type (TYPE_CODE_FLT, 35919370Spst TARGET_DOUBLE_BIT / TARGET_CHAR_BIT, 36019370Spst 0, "real*8", objfile); 36119370Spst break; 36219370Spst case FT_FLOAT_DECIMAL: 36319370Spst type = init_type (TYPE_CODE_FLT, 36419370Spst TARGET_DOUBLE_BIT / TARGET_CHAR_BIT, 36519370Spst 0, "floating decimal", objfile); 36619370Spst break; 36719370Spst case FT_EXT_PREC_FLOAT: 36819370Spst type = init_type (TYPE_CODE_FLT, 36919370Spst TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT, 37019370Spst 0, "real*16", objfile); 37119370Spst break; 37219370Spst case FT_COMPLEX: 37319370Spst type = init_type (TYPE_CODE_COMPLEX, 37419370Spst 2 * TARGET_FLOAT_BIT / TARGET_CHAR_BIT, 37519370Spst 0, "complex*8", objfile); 37619370Spst TYPE_TARGET_TYPE (type) = builtin_type_f_real; 37719370Spst break; 37819370Spst case FT_DBL_PREC_COMPLEX: 37919370Spst type = init_type (TYPE_CODE_COMPLEX, 38019370Spst 2 * TARGET_DOUBLE_BIT / TARGET_CHAR_BIT, 38119370Spst 0, "complex*16", objfile); 38219370Spst TYPE_TARGET_TYPE (type) = builtin_type_f_real_s8; 38319370Spst break; 38419370Spst case FT_EXT_PREC_COMPLEX: 38519370Spst type = init_type (TYPE_CODE_COMPLEX, 38619370Spst 2 * TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT, 38719370Spst 0, "complex*32", objfile); 38819370Spst TYPE_TARGET_TYPE (type) = builtin_type_f_real_s16; 38919370Spst break; 39019370Spst default: 39119370Spst /* FIXME: For now, if we are asked to produce a type not in this 39298944Sobrien language, create the equivalent of a C integer type with the 39398944Sobrien name "<?type?>". When all the dust settles from the type 39498944Sobrien reconstruction work, this should probably become an error. */ 39519370Spst type = init_type (TYPE_CODE_INT, 39619370Spst TARGET_INT_BIT / TARGET_CHAR_BIT, 39719370Spst 0, "<?type?>", objfile); 39819370Spst warning ("internal error: no F77 fundamental type %d", typeid); 39919370Spst break; 40019370Spst } 40119370Spst return (type); 40219370Spst} 40398944Sobrien 40419370Spst 40519370Spst/* Table of operators and their precedences for printing expressions. */ 40619370Spst 40798944Sobrienstatic const struct op_print f_op_print_tab[] = 40898944Sobrien{ 40998944Sobrien {"+", BINOP_ADD, PREC_ADD, 0}, 41098944Sobrien {"+", UNOP_PLUS, PREC_PREFIX, 0}, 41198944Sobrien {"-", BINOP_SUB, PREC_ADD, 0}, 41298944Sobrien {"-", UNOP_NEG, PREC_PREFIX, 0}, 41398944Sobrien {"*", BINOP_MUL, PREC_MUL, 0}, 41498944Sobrien {"/", BINOP_DIV, PREC_MUL, 0}, 41598944Sobrien {"DIV", BINOP_INTDIV, PREC_MUL, 0}, 41698944Sobrien {"MOD", BINOP_REM, PREC_MUL, 0}, 41798944Sobrien {"=", BINOP_ASSIGN, PREC_ASSIGN, 1}, 41898944Sobrien {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0}, 41998944Sobrien {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0}, 42098944Sobrien {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0}, 42198944Sobrien {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0}, 42298944Sobrien {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0}, 42398944Sobrien {".LE.", BINOP_LEQ, PREC_ORDER, 0}, 42498944Sobrien {".GE.", BINOP_GEQ, PREC_ORDER, 0}, 42598944Sobrien {".GT.", BINOP_GTR, PREC_ORDER, 0}, 42698944Sobrien {".LT.", BINOP_LESS, PREC_ORDER, 0}, 42798944Sobrien {"**", UNOP_IND, PREC_PREFIX, 0}, 42898944Sobrien {"@", BINOP_REPEAT, PREC_REPEAT, 0}, 42998944Sobrien {NULL, 0, 0, 0} 43019370Spst}; 43119370Spst 43298944Sobrienstruct type **const (f_builtin_types[]) = 43319370Spst{ 43419370Spst &builtin_type_f_character, 43598944Sobrien &builtin_type_f_logical, 43698944Sobrien &builtin_type_f_logical_s1, 43798944Sobrien &builtin_type_f_logical_s2, 43898944Sobrien &builtin_type_f_integer, 43998944Sobrien &builtin_type_f_integer_s2, 44098944Sobrien &builtin_type_f_real, 44198944Sobrien &builtin_type_f_real_s8, 44298944Sobrien &builtin_type_f_real_s16, 44398944Sobrien &builtin_type_f_complex_s8, 44498944Sobrien &builtin_type_f_complex_s16, 44519370Spst#if 0 44698944Sobrien &builtin_type_f_complex_s32, 44719370Spst#endif 44898944Sobrien &builtin_type_f_void, 44998944Sobrien 0 45019370Spst}; 45119370Spst 45246283Sdfr/* This is declared in c-lang.h but it is silly to import that file for what 45346283Sdfr is already just a hack. */ 45498944Sobrienextern int c_value_print (struct value *, struct ui_file *, int, 45598944Sobrien enum val_prettyprint); 45619370Spst 45798944Sobrienconst struct language_defn f_language_defn = 45898944Sobrien{ 45919370Spst "fortran", 46019370Spst language_fortran, 46119370Spst f_builtin_types, 46219370Spst range_check_on, 46319370Spst type_check_on, 46498944Sobrien case_sensitive_off, 465130803Smarcel &exp_descriptor_standard, 46619370Spst f_parse, /* parser */ 46719370Spst f_error, /* parser error function */ 46819370Spst f_printchar, /* Print character constant */ 46919370Spst f_printstr, /* function to print string constant */ 47046283Sdfr f_emit_char, /* Function to print a single character */ 47119370Spst f_create_fundamental_type, /* Create fundamental type in this language */ 47298944Sobrien f_print_type, /* Print a type using appropriate syntax */ 47319370Spst f_val_print, /* Print a value using appropriate syntax */ 47498944Sobrien c_value_print, /* FIXME */ 475130803Smarcel NULL, /* Language specific skip_trampoline */ 476130803Smarcel value_of_this, /* value_of_this */ 477130803Smarcel basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */ 478130803Smarcel basic_lookup_transparent_type,/* lookup_transparent_type */ 479130803Smarcel NULL, /* Language specific symbol demangler */ 48098944Sobrien {"", "", "", ""}, /* Binary format info */ 48198944Sobrien {"0%o", "0", "o", ""}, /* Octal format info */ 48298944Sobrien {"%d", "", "d", ""}, /* Decimal format info */ 48398944Sobrien {"0x%x", "0x", "x", ""}, /* Hex format info */ 48419370Spst f_op_print_tab, /* expression operators for printing */ 48519370Spst 0, /* arrays are first-class (not c-style) */ 48619370Spst 1, /* String lower bound */ 48798944Sobrien &builtin_type_f_character, /* Type of string elements */ 488130803Smarcel default_word_break_characters, 48919370Spst LANG_MAGIC 49098944Sobrien}; 49119370Spst 492130803Smarcelstatic void 493130803Smarcelbuild_fortran_types (void) 49419370Spst{ 49519370Spst builtin_type_f_void = 49619370Spst init_type (TYPE_CODE_VOID, 1, 49719370Spst 0, 49819370Spst "VOID", (struct objfile *) NULL); 49998944Sobrien 50019370Spst builtin_type_f_character = 50119370Spst init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT, 50219370Spst 0, 50319370Spst "character", (struct objfile *) NULL); 50498944Sobrien 50519370Spst builtin_type_f_logical_s1 = 50619370Spst init_type (TYPE_CODE_BOOL, TARGET_CHAR_BIT / TARGET_CHAR_BIT, 50719370Spst TYPE_FLAG_UNSIGNED, 50819370Spst "logical*1", (struct objfile *) NULL); 50998944Sobrien 51019370Spst builtin_type_f_integer_s2 = 51119370Spst init_type (TYPE_CODE_INT, TARGET_SHORT_BIT / TARGET_CHAR_BIT, 51219370Spst 0, 51319370Spst "integer*2", (struct objfile *) NULL); 51498944Sobrien 51519370Spst builtin_type_f_logical_s2 = 51619370Spst init_type (TYPE_CODE_BOOL, TARGET_SHORT_BIT / TARGET_CHAR_BIT, 51719370Spst TYPE_FLAG_UNSIGNED, 51819370Spst "logical*2", (struct objfile *) NULL); 51998944Sobrien 52019370Spst builtin_type_f_integer = 52119370Spst init_type (TYPE_CODE_INT, TARGET_INT_BIT / TARGET_CHAR_BIT, 52219370Spst 0, 52319370Spst "integer", (struct objfile *) NULL); 52498944Sobrien 52519370Spst builtin_type_f_logical = 52619370Spst init_type (TYPE_CODE_BOOL, TARGET_INT_BIT / TARGET_CHAR_BIT, 52719370Spst TYPE_FLAG_UNSIGNED, 52819370Spst "logical*4", (struct objfile *) NULL); 52998944Sobrien 53019370Spst builtin_type_f_real = 53119370Spst init_type (TYPE_CODE_FLT, TARGET_FLOAT_BIT / TARGET_CHAR_BIT, 53219370Spst 0, 53319370Spst "real", (struct objfile *) NULL); 53498944Sobrien 53519370Spst builtin_type_f_real_s8 = 53619370Spst init_type (TYPE_CODE_FLT, TARGET_DOUBLE_BIT / TARGET_CHAR_BIT, 53719370Spst 0, 53819370Spst "real*8", (struct objfile *) NULL); 53998944Sobrien 54019370Spst builtin_type_f_real_s16 = 54119370Spst init_type (TYPE_CODE_FLT, TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT, 54219370Spst 0, 54319370Spst "real*16", (struct objfile *) NULL); 54498944Sobrien 54519370Spst builtin_type_f_complex_s8 = 54619370Spst init_type (TYPE_CODE_COMPLEX, 2 * TARGET_FLOAT_BIT / TARGET_CHAR_BIT, 54719370Spst 0, 54819370Spst "complex*8", (struct objfile *) NULL); 54919370Spst TYPE_TARGET_TYPE (builtin_type_f_complex_s8) = builtin_type_f_real; 55098944Sobrien 55119370Spst builtin_type_f_complex_s16 = 55219370Spst init_type (TYPE_CODE_COMPLEX, 2 * TARGET_DOUBLE_BIT / TARGET_CHAR_BIT, 55319370Spst 0, 55419370Spst "complex*16", (struct objfile *) NULL); 55519370Spst TYPE_TARGET_TYPE (builtin_type_f_complex_s16) = builtin_type_f_real_s8; 55698944Sobrien 55719370Spst /* We have a new size == 4 double floats for the 55819370Spst complex*32 data type */ 55998944Sobrien 56098944Sobrien builtin_type_f_complex_s32 = 56119370Spst init_type (TYPE_CODE_COMPLEX, 2 * TARGET_LONG_DOUBLE_BIT / TARGET_CHAR_BIT, 56219370Spst 0, 56319370Spst "complex*32", (struct objfile *) NULL); 56419370Spst TYPE_TARGET_TYPE (builtin_type_f_complex_s32) = builtin_type_f_real_s16; 565130803Smarcel} 56619370Spst 567130803Smarcelvoid 568130803Smarcel_initialize_f_language (void) 569130803Smarcel{ 570130803Smarcel build_fortran_types (); 571130803Smarcel 572130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_character); 573130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_logical); 574130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_logical_s1); 575130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_logical_s2); 576130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_integer); 577130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_integer_s2); 578130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_real); 579130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_real_s8); 580130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_real_s16); 581130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_complex_s8); 582130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_complex_s16); 583130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_complex_s32); 584130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_f_void); 585130803Smarcel DEPRECATED_REGISTER_GDBARCH_SWAP (builtin_type_string); 586130803Smarcel deprecated_register_gdbarch_swap (NULL, 0, build_fortran_types); 587130803Smarcel 58819370Spst builtin_type_string = 58919370Spst init_type (TYPE_CODE_STRING, TARGET_CHAR_BIT / TARGET_CHAR_BIT, 59019370Spst 0, 59198944Sobrien "character string", (struct objfile *) NULL); 59298944Sobrien 59319370Spst add_language (&f_language_defn); 59419370Spst} 59519370Spst 59646283Sdfr#if 0 59746283Sdfrstatic SAVED_BF_PTR 59898944Sobrienallocate_saved_bf_node (void) 59919370Spst{ 60019370Spst SAVED_BF_PTR new; 60198944Sobrien 60219370Spst new = (SAVED_BF_PTR) xmalloc (sizeof (SAVED_BF)); 60398944Sobrien return (new); 60419370Spst} 60519370Spst 60646283Sdfrstatic SAVED_FUNCTION * 60798944Sobrienallocate_saved_function_node (void) 60819370Spst{ 60919370Spst SAVED_FUNCTION *new; 61098944Sobrien 61119370Spst new = (SAVED_FUNCTION *) xmalloc (sizeof (SAVED_FUNCTION)); 61298944Sobrien return (new); 61319370Spst} 61419370Spst 61598944Sobrienstatic SAVED_F77_COMMON_PTR 61698944Sobrienallocate_saved_f77_common_node (void) 61719370Spst{ 61819370Spst SAVED_F77_COMMON_PTR new; 61998944Sobrien 62019370Spst new = (SAVED_F77_COMMON_PTR) xmalloc (sizeof (SAVED_F77_COMMON)); 62198944Sobrien return (new); 62219370Spst} 62319370Spst 62498944Sobrienstatic COMMON_ENTRY_PTR 62598944Sobrienallocate_common_entry_node (void) 62619370Spst{ 62719370Spst COMMON_ENTRY_PTR new; 62898944Sobrien 62919370Spst new = (COMMON_ENTRY_PTR) xmalloc (sizeof (COMMON_ENTRY)); 63098944Sobrien return (new); 63119370Spst} 63246283Sdfr#endif 63319370Spst 63498944SobrienSAVED_F77_COMMON_PTR head_common_list = NULL; /* Ptr to 1st saved COMMON */ 63598944SobrienSAVED_F77_COMMON_PTR tail_common_list = NULL; /* Ptr to last saved COMMON */ 63698944SobrienSAVED_F77_COMMON_PTR current_common = NULL; /* Ptr to current COMMON */ 63719370Spst 63846283Sdfr#if 0 63998944Sobrienstatic SAVED_BF_PTR saved_bf_list = NULL; /* Ptr to (.bf,function) 64098944Sobrien list */ 64198944Sobrienstatic SAVED_BF_PTR saved_bf_list_end = NULL; /* Ptr to above list's end */ 64298944Sobrienstatic SAVED_BF_PTR current_head_bf_list = NULL; /* Current head of above list 64398944Sobrien */ 64419370Spst 64598944Sobrienstatic SAVED_BF_PTR tmp_bf_ptr; /* Generic temporary for use 64698944Sobrien in macros */ 64719370Spst 64819370Spst/* The following function simply enters a given common block onto 64919370Spst the global common block chain */ 65019370Spst 65146283Sdfrstatic void 65298944Sobrienadd_common_block (char *name, CORE_ADDR offset, int secnum, char *func_stab) 65319370Spst{ 65419370Spst SAVED_F77_COMMON_PTR tmp; 65598944Sobrien char *c, *local_copy_func_stab; 65698944Sobrien 65719370Spst /* If the COMMON block we are trying to add has a blank 65819370Spst name (i.e. "#BLNK_COM") then we set it to __BLANK 65919370Spst because the darn "#" character makes GDB's input 66098944Sobrien parser have fits. */ 66198944Sobrien 66298944Sobrien 663130803Smarcel if (strcmp (name, BLANK_COMMON_NAME_ORIGINAL) == 0 664130803Smarcel || strcmp (name, BLANK_COMMON_NAME_MF77) == 0) 66519370Spst { 66698944Sobrien 66798944Sobrien xfree (name); 66898944Sobrien name = alloca (strlen (BLANK_COMMON_NAME_LOCAL) + 1); 66998944Sobrien strcpy (name, BLANK_COMMON_NAME_LOCAL); 67019370Spst } 67198944Sobrien 67298944Sobrien tmp = allocate_saved_f77_common_node (); 67398944Sobrien 67498944Sobrien local_copy_func_stab = xmalloc (strlen (func_stab) + 1); 67598944Sobrien strcpy (local_copy_func_stab, func_stab); 67698944Sobrien 67798944Sobrien tmp->name = xmalloc (strlen (name) + 1); 67898944Sobrien 67919370Spst /* local_copy_func_stab is a stabstring, let us first extract the 68098944Sobrien function name from the stab by NULLing out the ':' character. */ 68198944Sobrien 68298944Sobrien 68398944Sobrien c = NULL; 68498944Sobrien c = strchr (local_copy_func_stab, ':'); 68598944Sobrien 68619370Spst if (c) 68719370Spst *c = '\0'; 68819370Spst else 68998944Sobrien error ("Malformed function STAB found in add_common_block()"); 69098944Sobrien 69198944Sobrien 69298944Sobrien tmp->owning_function = xmalloc (strlen (local_copy_func_stab) + 1); 69398944Sobrien 69498944Sobrien strcpy (tmp->owning_function, local_copy_func_stab); 69598944Sobrien 69698944Sobrien strcpy (tmp->name, name); 69798944Sobrien tmp->offset = offset; 69819370Spst tmp->next = NULL; 69919370Spst tmp->entries = NULL; 70098944Sobrien tmp->secnum = secnum; 70198944Sobrien 70219370Spst current_common = tmp; 70398944Sobrien 70419370Spst if (head_common_list == NULL) 70519370Spst { 70619370Spst head_common_list = tail_common_list = tmp; 70719370Spst } 70819370Spst else 70919370Spst { 71098944Sobrien tail_common_list->next = tmp; 71119370Spst tail_common_list = tmp; 71219370Spst } 71319370Spst} 71446283Sdfr#endif 71519370Spst 71619370Spst/* The following function simply enters a given common entry onto 71798944Sobrien the "current_common" block that has been saved away. */ 71819370Spst 71946283Sdfr#if 0 72046283Sdfrstatic void 72198944Sobrienadd_common_entry (struct symbol *entry_sym_ptr) 72219370Spst{ 72319370Spst COMMON_ENTRY_PTR tmp; 72498944Sobrien 72598944Sobrien 72698944Sobrien 72719370Spst /* The order of this list is important, since 72819370Spst we expect the entries to appear in decl. 72998944Sobrien order when we later issue "info common" calls */ 73098944Sobrien 73198944Sobrien tmp = allocate_common_entry_node (); 73298944Sobrien 73319370Spst tmp->next = NULL; 73419370Spst tmp->symbol = entry_sym_ptr; 73598944Sobrien 73619370Spst if (current_common == NULL) 73798944Sobrien error ("Attempt to add COMMON entry with no block open!"); 73898944Sobrien else 73919370Spst { 74019370Spst if (current_common->entries == NULL) 74119370Spst { 74219370Spst current_common->entries = tmp; 74398944Sobrien current_common->end_of_entries = tmp; 74419370Spst } 74519370Spst else 74619370Spst { 74798944Sobrien current_common->end_of_entries->next = tmp; 74898944Sobrien current_common->end_of_entries = tmp; 74919370Spst } 75019370Spst } 75119370Spst} 75246283Sdfr#endif 75319370Spst 75498944Sobrien/* This routine finds the first encountred COMMON block named "name" */ 75519370Spst 75646283Sdfr#if 0 75746283Sdfrstatic SAVED_F77_COMMON_PTR 75898944Sobrienfind_first_common_named (char *name) 75919370Spst{ 76098944Sobrien 76119370Spst SAVED_F77_COMMON_PTR tmp; 76298944Sobrien 76319370Spst tmp = head_common_list; 76498944Sobrien 76519370Spst while (tmp != NULL) 76619370Spst { 767130803Smarcel if (strcmp (tmp->name, name) == 0) 76898944Sobrien return (tmp); 76919370Spst else 77019370Spst tmp = tmp->next; 77119370Spst } 77298944Sobrien return (NULL); 77319370Spst} 77446283Sdfr#endif 77519370Spst 77619370Spst/* This routine finds the first encountred COMMON block named "name" 77798944Sobrien that belongs to function funcname */ 77819370Spst 77998944SobrienSAVED_F77_COMMON_PTR 78098944Sobrienfind_common_for_function (char *name, char *funcname) 78119370Spst{ 78298944Sobrien 78319370Spst SAVED_F77_COMMON_PTR tmp; 78498944Sobrien 78519370Spst tmp = head_common_list; 78698944Sobrien 78719370Spst while (tmp != NULL) 78819370Spst { 789130803Smarcel if (DEPRECATED_STREQ (tmp->name, name) 790130803Smarcel && DEPRECATED_STREQ (tmp->owning_function, funcname)) 79198944Sobrien return (tmp); 79219370Spst else 79319370Spst tmp = tmp->next; 79419370Spst } 79598944Sobrien return (NULL); 79619370Spst} 79719370Spst 79819370Spst 79946283Sdfr#if 0 80019370Spst 80119370Spst/* The following function is called to patch up the offsets 80219370Spst for the statics contained in the COMMON block named 80398944Sobrien "name." */ 80419370Spst 80546283Sdfrstatic void 80698944Sobrienpatch_common_entries (SAVED_F77_COMMON_PTR blk, CORE_ADDR offset, int secnum) 80719370Spst{ 80819370Spst COMMON_ENTRY_PTR entry; 80998944Sobrien 81098944Sobrien blk->offset = offset; /* Keep this around for future use. */ 81198944Sobrien 81219370Spst entry = blk->entries; 81398944Sobrien 81419370Spst while (entry != NULL) 81519370Spst { 81698944Sobrien SYMBOL_VALUE (entry->symbol) += offset; 81719370Spst SYMBOL_SECTION (entry->symbol) = secnum; 81898944Sobrien 81919370Spst entry = entry->next; 82019370Spst } 82198944Sobrien blk->secnum = secnum; 82219370Spst} 82319370Spst 82419370Spst/* Patch all commons named "name" that need patching.Since COMMON 82519370Spst blocks occur with relative infrequency, we simply do a linear scan on 82619370Spst the name. Eventually, the best way to do this will be a 82719370Spst hashed-lookup. Secnum is the section number for the .bss section 82819370Spst (which is where common data lives). */ 82919370Spst 83046283Sdfrstatic void 83198944Sobrienpatch_all_commons_by_name (char *name, CORE_ADDR offset, int secnum) 83219370Spst{ 83398944Sobrien 83419370Spst SAVED_F77_COMMON_PTR tmp; 83598944Sobrien 83619370Spst /* For blank common blocks, change the canonical reprsentation 83719370Spst of a blank name */ 83898944Sobrien 839130803Smarcel if (strcmp (name, BLANK_COMMON_NAME_ORIGINAL) == 0 840130803Smarcel || strcmp (name, BLANK_COMMON_NAME_MF77) == 0) 84119370Spst { 84298944Sobrien xfree (name); 84398944Sobrien name = alloca (strlen (BLANK_COMMON_NAME_LOCAL) + 1); 84498944Sobrien strcpy (name, BLANK_COMMON_NAME_LOCAL); 84519370Spst } 84698944Sobrien 84719370Spst tmp = head_common_list; 84898944Sobrien 84919370Spst while (tmp != NULL) 85019370Spst { 85198944Sobrien if (COMMON_NEEDS_PATCHING (tmp)) 852130803Smarcel if (strcmp (tmp->name, name) == 0) 85398944Sobrien patch_common_entries (tmp, offset, secnum); 85498944Sobrien 85519370Spst tmp = tmp->next; 85698944Sobrien } 85719370Spst} 85846283Sdfr#endif 85919370Spst 86019370Spst/* This macro adds the symbol-number for the start of the function 86119370Spst (the symbol number of the .bf) referenced by symnum_fcn to a 86219370Spst list. This list, in reality should be a FIFO queue but since 86319370Spst #line pragmas sometimes cause line ranges to get messed up 86419370Spst we simply create a linear list. This list can then be searched 86519370Spst first by a queueing algorithm and upon failure fall back to 86698944Sobrien a linear scan. */ 86719370Spst 86819370Spst#if 0 86919370Spst#define ADD_BF_SYMNUM(bf_sym,fcn_sym) \ 87019370Spst \ 87119370Spst if (saved_bf_list == NULL) \ 87219370Spst{ \ 87319370Spst tmp_bf_ptr = allocate_saved_bf_node(); \ 87419370Spst \ 87519370Spst tmp_bf_ptr->symnum_bf = (bf_sym); \ 87619370Spst tmp_bf_ptr->symnum_fcn = (fcn_sym); \ 87719370Spst tmp_bf_ptr->next = NULL; \ 87819370Spst \ 87919370Spst current_head_bf_list = saved_bf_list = tmp_bf_ptr; \ 88019370Spst saved_bf_list_end = tmp_bf_ptr; \ 88119370Spst } \ 88219370Spstelse \ 88319370Spst{ \ 88419370Spst tmp_bf_ptr = allocate_saved_bf_node(); \ 88519370Spst \ 88619370Spst tmp_bf_ptr->symnum_bf = (bf_sym); \ 88719370Spst tmp_bf_ptr->symnum_fcn = (fcn_sym); \ 88819370Spst tmp_bf_ptr->next = NULL; \ 88919370Spst \ 89019370Spst saved_bf_list_end->next = tmp_bf_ptr; \ 89119370Spst saved_bf_list_end = tmp_bf_ptr; \ 89298944Sobrien } 89319370Spst#endif 89419370Spst 89598944Sobrien/* This function frees the entire (.bf,function) list */ 89619370Spst 89746283Sdfr#if 0 89898944Sobrienstatic void 89998944Sobrienclear_bf_list (void) 90019370Spst{ 90198944Sobrien 90219370Spst SAVED_BF_PTR tmp = saved_bf_list; 90398944Sobrien SAVED_BF_PTR next = NULL; 90498944Sobrien 90519370Spst while (tmp != NULL) 90619370Spst { 90719370Spst next = tmp->next; 90898944Sobrien xfree (tmp); 90998944Sobrien tmp = next; 91019370Spst } 91119370Spst saved_bf_list = NULL; 91219370Spst} 91346283Sdfr#endif 91419370Spst 91519370Spstint global_remote_debug; 91619370Spst 91746283Sdfr#if 0 91846283Sdfr 91946283Sdfrstatic long 92098944Sobrienget_bf_for_fcn (long the_function) 92119370Spst{ 92219370Spst SAVED_BF_PTR tmp; 92319370Spst int nprobes = 0; 92498944Sobrien 92519370Spst /* First use a simple queuing algorithm (i.e. look and see if the 92619370Spst item at the head of the queue is the one you want) */ 92798944Sobrien 92819370Spst if (saved_bf_list == NULL) 92998944Sobrien internal_error (__FILE__, __LINE__, 93098944Sobrien "cannot get .bf node off empty list"); 93198944Sobrien 93298944Sobrien if (current_head_bf_list != NULL) 93319370Spst if (current_head_bf_list->symnum_fcn == the_function) 93419370Spst { 93598944Sobrien if (global_remote_debug) 936130803Smarcel fprintf_unfiltered (gdb_stderr, "*"); 93719370Spst 93898944Sobrien tmp = current_head_bf_list; 93919370Spst current_head_bf_list = current_head_bf_list->next; 94098944Sobrien return (tmp->symnum_bf); 94119370Spst } 94298944Sobrien 94319370Spst /* If the above did not work (probably because #line directives were 94419370Spst used in the sourcefile and they messed up our internal tables) we now do 94519370Spst the ugly linear scan */ 94698944Sobrien 94798944Sobrien if (global_remote_debug) 948130803Smarcel fprintf_unfiltered (gdb_stderr, "\ndefaulting to linear scan\n"); 94998944Sobrien 95098944Sobrien nprobes = 0; 95119370Spst tmp = saved_bf_list; 95219370Spst while (tmp != NULL) 95319370Spst { 95498944Sobrien nprobes++; 95519370Spst if (tmp->symnum_fcn == the_function) 95698944Sobrien { 95719370Spst if (global_remote_debug) 958130803Smarcel fprintf_unfiltered (gdb_stderr, "Found in %d probes\n", nprobes); 95919370Spst current_head_bf_list = tmp->next; 96098944Sobrien return (tmp->symnum_bf); 96198944Sobrien } 96298944Sobrien tmp = tmp->next; 96319370Spst } 96498944Sobrien 96598944Sobrien return (-1); 96619370Spst} 96719370Spst 96898944Sobrienstatic SAVED_FUNCTION_PTR saved_function_list = NULL; 96998944Sobrienstatic SAVED_FUNCTION_PTR saved_function_list_end = NULL; 97019370Spst 97146283Sdfrstatic void 97298944Sobrienclear_function_list (void) 97319370Spst{ 97419370Spst SAVED_FUNCTION_PTR tmp = saved_function_list; 97598944Sobrien SAVED_FUNCTION_PTR next = NULL; 97698944Sobrien 97719370Spst while (tmp != NULL) 97819370Spst { 97919370Spst next = tmp->next; 98098944Sobrien xfree (tmp); 98119370Spst tmp = next; 98219370Spst } 98398944Sobrien 98419370Spst saved_function_list = NULL; 98519370Spst} 98646283Sdfr#endif 987