1/* Fortran language support routines for GDB, the GNU debugger. 2 3 Copyright (C) 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001, 2002, 2003, 4 2004, 2005, 2007 Free Software Foundation, Inc. 5 6 Contributed by Motorola. Adapted from the C parser by Farooq Butt 7 (fmbutt@engage.sps.mot.com). 8 9 This file is part of GDB. 10 11 This program is free software; you can redistribute it and/or modify 12 it under the terms of the GNU General Public License as published by 13 the Free Software Foundation; either version 3 of the License, or 14 (at your option) any later version. 15 16 This program is distributed in the hope that it will be useful, 17 but WITHOUT ANY WARRANTY; without even the implied warranty of 18 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 GNU General Public License for more details. 20 21 You should have received a copy of the GNU General Public License 22 along with this program. If not, see <http://www.gnu.org/licenses/>. */ 23 24#include "defs.h" 25#include "gdb_string.h" 26#include "symtab.h" 27#include "gdbtypes.h" 28#include "expression.h" 29#include "parser-defs.h" 30#include "language.h" 31#include "f-lang.h" 32#include "valprint.h" 33#include "value.h" 34 35 36/* Following is dubious stuff that had been in the xcoff reader. */ 37 38struct saved_fcn 39 { 40 long line_offset; /* Line offset for function */ 41 struct saved_fcn *next; 42 }; 43 44 45struct saved_bf_symnum 46 { 47 long symnum_fcn; /* Symnum of function (i.e. .function directive) */ 48 long symnum_bf; /* Symnum of .bf for this function */ 49 struct saved_bf_symnum *next; 50 }; 51 52typedef struct saved_fcn SAVED_FUNCTION, *SAVED_FUNCTION_PTR; 53typedef struct saved_bf_symnum SAVED_BF, *SAVED_BF_PTR; 54 55/* Local functions */ 56 57extern void _initialize_f_language (void); 58#if 0 59static void clear_function_list (void); 60static long get_bf_for_fcn (long); 61static void clear_bf_list (void); 62static void patch_all_commons_by_name (char *, CORE_ADDR, int); 63static SAVED_F77_COMMON_PTR find_first_common_named (char *); 64static void add_common_entry (struct symbol *); 65static void add_common_block (char *, CORE_ADDR, int, char *); 66static SAVED_FUNCTION *allocate_saved_function_node (void); 67static SAVED_BF_PTR allocate_saved_bf_node (void); 68static COMMON_ENTRY_PTR allocate_common_entry_node (void); 69static SAVED_F77_COMMON_PTR allocate_saved_f77_common_node (void); 70static void patch_common_entries (SAVED_F77_COMMON_PTR, CORE_ADDR, int); 71#endif 72 73static struct type *f_create_fundamental_type (struct objfile *, int); 74static void f_printchar (int c, struct ui_file * stream); 75static void f_emit_char (int c, struct ui_file * stream, int quoter); 76 77/* Print the character C on STREAM as part of the contents of a literal 78 string whose delimiter is QUOTER. Note that that format for printing 79 characters and strings is language specific. 80 FIXME: This is a copy of the same function from c-exp.y. It should 81 be replaced with a true F77 version. */ 82 83static void 84f_emit_char (int c, struct ui_file *stream, int quoter) 85{ 86 c &= 0xFF; /* Avoid sign bit follies */ 87 88 if (PRINT_LITERAL_FORM (c)) 89 { 90 if (c == '\\' || c == quoter) 91 fputs_filtered ("\\", stream); 92 fprintf_filtered (stream, "%c", c); 93 } 94 else 95 { 96 switch (c) 97 { 98 case '\n': 99 fputs_filtered ("\\n", stream); 100 break; 101 case '\b': 102 fputs_filtered ("\\b", stream); 103 break; 104 case '\t': 105 fputs_filtered ("\\t", stream); 106 break; 107 case '\f': 108 fputs_filtered ("\\f", stream); 109 break; 110 case '\r': 111 fputs_filtered ("\\r", stream); 112 break; 113 case '\033': 114 fputs_filtered ("\\e", stream); 115 break; 116 case '\007': 117 fputs_filtered ("\\a", stream); 118 break; 119 default: 120 fprintf_filtered (stream, "\\%.3o", (unsigned int) c); 121 break; 122 } 123 } 124} 125 126/* FIXME: This is a copy of the same function from c-exp.y. It should 127 be replaced with a true F77version. */ 128 129static void 130f_printchar (int c, struct ui_file *stream) 131{ 132 fputs_filtered ("'", stream); 133 LA_EMIT_CHAR (c, stream, '\''); 134 fputs_filtered ("'", stream); 135} 136 137/* Print the character string STRING, printing at most LENGTH characters. 138 Printing stops early if the number hits print_max; repeat counts 139 are printed as appropriate. Print ellipses at the end if we 140 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES. 141 FIXME: This is a copy of the same function from c-exp.y. It should 142 be replaced with a true F77 version. */ 143 144static void 145f_printstr (struct ui_file *stream, const gdb_byte *string, 146 unsigned int length, int width, int force_ellipses) 147{ 148 unsigned int i; 149 unsigned int things_printed = 0; 150 int in_quotes = 0; 151 int need_comma = 0; 152 153 if (length == 0) 154 { 155 fputs_filtered ("''", gdb_stdout); 156 return; 157 } 158 159 for (i = 0; i < length && things_printed < print_max; ++i) 160 { 161 /* Position of the character we are examining 162 to see whether it is repeated. */ 163 unsigned int rep1; 164 /* Number of repetitions we have detected so far. */ 165 unsigned int reps; 166 167 QUIT; 168 169 if (need_comma) 170 { 171 fputs_filtered (", ", stream); 172 need_comma = 0; 173 } 174 175 rep1 = i + 1; 176 reps = 1; 177 while (rep1 < length && string[rep1] == string[i]) 178 { 179 ++rep1; 180 ++reps; 181 } 182 183 if (reps > repeat_count_threshold) 184 { 185 if (in_quotes) 186 { 187 if (inspect_it) 188 fputs_filtered ("\\', ", stream); 189 else 190 fputs_filtered ("', ", stream); 191 in_quotes = 0; 192 } 193 f_printchar (string[i], stream); 194 fprintf_filtered (stream, " <repeats %u times>", reps); 195 i = rep1 - 1; 196 things_printed += repeat_count_threshold; 197 need_comma = 1; 198 } 199 else 200 { 201 if (!in_quotes) 202 { 203 if (inspect_it) 204 fputs_filtered ("\\'", stream); 205 else 206 fputs_filtered ("'", stream); 207 in_quotes = 1; 208 } 209 LA_EMIT_CHAR (string[i], stream, '"'); 210 ++things_printed; 211 } 212 } 213 214 /* Terminate the quotes if necessary. */ 215 if (in_quotes) 216 { 217 if (inspect_it) 218 fputs_filtered ("\\'", stream); 219 else 220 fputs_filtered ("'", stream); 221 } 222 223 if (force_ellipses || i < length) 224 fputs_filtered ("...", stream); 225} 226 227/* FIXME: This is a copy of c_create_fundamental_type(), before 228 all the non-C types were stripped from it. Needs to be fixed 229 by an experienced F77 programmer. */ 230 231static struct type * 232f_create_fundamental_type (struct objfile *objfile, int typeid) 233{ 234 struct type *type = NULL; 235 236 switch (typeid) 237 { 238 case FT_VOID: 239 type = init_type (TYPE_CODE_VOID, 240 TARGET_CHAR_BIT / TARGET_CHAR_BIT, 241 0, "VOID", objfile); 242 break; 243 case FT_BOOLEAN: 244 type = init_type (TYPE_CODE_BOOL, 245 TARGET_CHAR_BIT / TARGET_CHAR_BIT, 246 TYPE_FLAG_UNSIGNED, "boolean", objfile); 247 break; 248 case FT_STRING: 249 type = init_type (TYPE_CODE_STRING, 250 TARGET_CHAR_BIT / TARGET_CHAR_BIT, 251 0, "string", objfile); 252 break; 253 case FT_CHAR: 254 type = init_type (TYPE_CODE_INT, 255 TARGET_CHAR_BIT / TARGET_CHAR_BIT, 256 0, "character", objfile); 257 break; 258 case FT_SIGNED_CHAR: 259 type = init_type (TYPE_CODE_INT, 260 TARGET_CHAR_BIT / TARGET_CHAR_BIT, 261 0, "integer*1", objfile); 262 break; 263 case FT_UNSIGNED_CHAR: 264 type = init_type (TYPE_CODE_BOOL, 265 TARGET_CHAR_BIT / TARGET_CHAR_BIT, 266 TYPE_FLAG_UNSIGNED, "logical*1", objfile); 267 break; 268 case FT_SHORT: 269 type = init_type (TYPE_CODE_INT, 270 gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT, 271 0, "integer*2", objfile); 272 break; 273 case FT_SIGNED_SHORT: 274 type = init_type (TYPE_CODE_INT, 275 gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT, 276 0, "short", objfile); /* FIXME-fnf */ 277 break; 278 case FT_UNSIGNED_SHORT: 279 type = init_type (TYPE_CODE_BOOL, 280 gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT, 281 TYPE_FLAG_UNSIGNED, "logical*2", objfile); 282 break; 283 case FT_INTEGER: 284 type = init_type (TYPE_CODE_INT, 285 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT, 286 0, "integer*4", objfile); 287 break; 288 case FT_SIGNED_INTEGER: 289 type = init_type (TYPE_CODE_INT, 290 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT, 291 0, "integer", objfile); /* FIXME -fnf */ 292 break; 293 case FT_UNSIGNED_INTEGER: 294 type = init_type (TYPE_CODE_BOOL, 295 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT, 296 TYPE_FLAG_UNSIGNED, "logical*4", objfile); 297 break; 298 case FT_FIXED_DECIMAL: 299 type = init_type (TYPE_CODE_INT, 300 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT, 301 0, "fixed decimal", objfile); 302 break; 303 case FT_LONG: 304 type = init_type (TYPE_CODE_INT, 305 gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT, 306 0, "long", objfile); 307 break; 308 case FT_SIGNED_LONG: 309 type = init_type (TYPE_CODE_INT, 310 gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT, 311 0, "long", objfile); /* FIXME -fnf */ 312 break; 313 case FT_UNSIGNED_LONG: 314 type = init_type (TYPE_CODE_INT, 315 gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT, 316 TYPE_FLAG_UNSIGNED, "unsigned long", objfile); 317 break; 318 case FT_LONG_LONG: 319 type = init_type (TYPE_CODE_INT, 320 gdbarch_long_long_bit (current_gdbarch) 321 / TARGET_CHAR_BIT, 322 0, "long long", objfile); 323 break; 324 case FT_SIGNED_LONG_LONG: 325 type = init_type (TYPE_CODE_INT, 326 gdbarch_long_long_bit (current_gdbarch) 327 / TARGET_CHAR_BIT, 328 0, "signed long long", objfile); 329 break; 330 case FT_UNSIGNED_LONG_LONG: 331 type = init_type (TYPE_CODE_INT, 332 gdbarch_long_long_bit (current_gdbarch) 333 / TARGET_CHAR_BIT, 334 TYPE_FLAG_UNSIGNED, "unsigned long long", objfile); 335 break; 336 case FT_FLOAT: 337 type = init_type (TYPE_CODE_FLT, 338 gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT, 339 0, "real", objfile); 340 break; 341 case FT_DBL_PREC_FLOAT: 342 type = init_type (TYPE_CODE_FLT, 343 gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT, 344 0, "real*8", objfile); 345 break; 346 case FT_FLOAT_DECIMAL: 347 type = init_type (TYPE_CODE_FLT, 348 gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT, 349 0, "floating decimal", objfile); 350 break; 351 case FT_EXT_PREC_FLOAT: 352 type = init_type (TYPE_CODE_FLT, 353 gdbarch_long_double_bit (current_gdbarch) 354 / TARGET_CHAR_BIT, 355 0, "real*16", objfile); 356 break; 357 case FT_COMPLEX: 358 type = init_type (TYPE_CODE_COMPLEX, 359 2 * gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT, 360 0, "complex*8", objfile); 361 TYPE_TARGET_TYPE (type) = builtin_type_f_real; 362 break; 363 case FT_DBL_PREC_COMPLEX: 364 type = init_type (TYPE_CODE_COMPLEX, 365 2 * gdbarch_double_bit (current_gdbarch) 366 / TARGET_CHAR_BIT, 367 0, "complex*16", objfile); 368 TYPE_TARGET_TYPE (type) = builtin_type_f_real_s8; 369 break; 370 case FT_EXT_PREC_COMPLEX: 371 type = init_type (TYPE_CODE_COMPLEX, 372 2 * gdbarch_long_double_bit (current_gdbarch) 373 / TARGET_CHAR_BIT, 374 0, "complex*32", objfile); 375 TYPE_TARGET_TYPE (type) = builtin_type_f_real_s16; 376 break; 377 default: 378 /* FIXME: For now, if we are asked to produce a type not in this 379 language, create the equivalent of a C integer type with the 380 name "<?type?>". When all the dust settles from the type 381 reconstruction work, this should probably become an error. */ 382 type = init_type (TYPE_CODE_INT, 383 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT, 384 0, "<?type?>", objfile); 385 warning (_("internal error: no F77 fundamental type %d"), typeid); 386 break; 387 } 388 return (type); 389} 390 391 392/* Table of operators and their precedences for printing expressions. */ 393 394static const struct op_print f_op_print_tab[] = 395{ 396 {"+", BINOP_ADD, PREC_ADD, 0}, 397 {"+", UNOP_PLUS, PREC_PREFIX, 0}, 398 {"-", BINOP_SUB, PREC_ADD, 0}, 399 {"-", UNOP_NEG, PREC_PREFIX, 0}, 400 {"*", BINOP_MUL, PREC_MUL, 0}, 401 {"/", BINOP_DIV, PREC_MUL, 0}, 402 {"DIV", BINOP_INTDIV, PREC_MUL, 0}, 403 {"MOD", BINOP_REM, PREC_MUL, 0}, 404 {"=", BINOP_ASSIGN, PREC_ASSIGN, 1}, 405 {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0}, 406 {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0}, 407 {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0}, 408 {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0}, 409 {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0}, 410 {".LE.", BINOP_LEQ, PREC_ORDER, 0}, 411 {".GE.", BINOP_GEQ, PREC_ORDER, 0}, 412 {".GT.", BINOP_GTR, PREC_ORDER, 0}, 413 {".LT.", BINOP_LESS, PREC_ORDER, 0}, 414 {"**", UNOP_IND, PREC_PREFIX, 0}, 415 {"@", BINOP_REPEAT, PREC_REPEAT, 0}, 416 {NULL, 0, 0, 0} 417}; 418 419enum f_primitive_types { 420 f_primitive_type_character, 421 f_primitive_type_logical, 422 f_primitive_type_logical_s1, 423 f_primitive_type_logical_s2, 424 f_primitive_type_integer, 425 f_primitive_type_integer_s2, 426 f_primitive_type_real, 427 f_primitive_type_real_s8, 428 f_primitive_type_real_s16, 429 f_primitive_type_complex_s8, 430 f_primitive_type_complex_s16, 431 f_primitive_type_void, 432 nr_f_primitive_types 433}; 434 435static void 436f_language_arch_info (struct gdbarch *gdbarch, 437 struct language_arch_info *lai) 438{ 439 const struct builtin_f_type *builtin = builtin_f_type (gdbarch); 440 441 lai->string_char_type = builtin->builtin_character; 442 lai->primitive_type_vector 443 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1, 444 struct type *); 445 446 lai->primitive_type_vector [f_primitive_type_character] 447 = builtin->builtin_character; 448 lai->primitive_type_vector [f_primitive_type_logical] 449 = builtin->builtin_logical; 450 lai->primitive_type_vector [f_primitive_type_logical_s1] 451 = builtin->builtin_logical_s1; 452 lai->primitive_type_vector [f_primitive_type_logical_s2] 453 = builtin->builtin_logical_s2; 454 lai->primitive_type_vector [f_primitive_type_real] 455 = builtin->builtin_real; 456 lai->primitive_type_vector [f_primitive_type_real_s8] 457 = builtin->builtin_real_s8; 458 lai->primitive_type_vector [f_primitive_type_real_s16] 459 = builtin->builtin_real_s16; 460 lai->primitive_type_vector [f_primitive_type_complex_s8] 461 = builtin->builtin_complex_s8; 462 lai->primitive_type_vector [f_primitive_type_complex_s16] 463 = builtin->builtin_complex_s16; 464 lai->primitive_type_vector [f_primitive_type_void] 465 = builtin->builtin_void; 466} 467 468/* This is declared in c-lang.h but it is silly to import that file for what 469 is already just a hack. */ 470extern int c_value_print (struct value *, struct ui_file *, int, 471 enum val_prettyprint); 472 473const struct language_defn f_language_defn = 474{ 475 "fortran", 476 language_fortran, 477 NULL, 478 range_check_on, 479 type_check_on, 480 case_sensitive_off, 481 array_column_major, 482 &exp_descriptor_standard, 483 f_parse, /* parser */ 484 f_error, /* parser error function */ 485 null_post_parser, 486 f_printchar, /* Print character constant */ 487 f_printstr, /* function to print string constant */ 488 f_emit_char, /* Function to print a single character */ 489 f_create_fundamental_type, /* Create fundamental type in this language */ 490 f_print_type, /* Print a type using appropriate syntax */ 491 f_val_print, /* Print a value using appropriate syntax */ 492 c_value_print, /* FIXME */ 493 NULL, /* Language specific skip_trampoline */ 494 value_of_this, /* value_of_this */ 495 basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */ 496 basic_lookup_transparent_type,/* lookup_transparent_type */ 497 NULL, /* Language specific symbol demangler */ 498 NULL, /* Language specific class_name_from_physname */ 499 f_op_print_tab, /* expression operators for printing */ 500 0, /* arrays are first-class (not c-style) */ 501 1, /* String lower bound */ 502 NULL, 503 default_word_break_characters, 504 f_language_arch_info, 505 default_print_array_index, 506 LANG_MAGIC 507}; 508 509static void * 510build_fortran_types (struct gdbarch *gdbarch) 511{ 512 struct builtin_f_type *builtin_f_type 513 = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type); 514 515 builtin_f_type->builtin_void = 516 init_type (TYPE_CODE_VOID, 1, 517 0, 518 "VOID", (struct objfile *) NULL); 519 520 builtin_f_type->builtin_character = 521 init_type (TYPE_CODE_INT, TARGET_CHAR_BIT / TARGET_CHAR_BIT, 522 0, 523 "character", (struct objfile *) NULL); 524 525 builtin_f_type->builtin_logical_s1 = 526 init_type (TYPE_CODE_BOOL, TARGET_CHAR_BIT / TARGET_CHAR_BIT, 527 TYPE_FLAG_UNSIGNED, 528 "logical*1", (struct objfile *) NULL); 529 530 builtin_f_type->builtin_integer_s2 = 531 init_type (TYPE_CODE_INT, 532 gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT, 533 0, "integer*2", (struct objfile *) NULL); 534 535 builtin_f_type->builtin_logical_s2 = 536 init_type (TYPE_CODE_BOOL, 537 gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT, 538 TYPE_FLAG_UNSIGNED, "logical*2", (struct objfile *) NULL); 539 540 builtin_f_type->builtin_integer = 541 init_type (TYPE_CODE_INT, 542 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT, 543 0, "integer", (struct objfile *) NULL); 544 545 builtin_f_type->builtin_logical = 546 init_type (TYPE_CODE_BOOL, 547 gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT, 548 TYPE_FLAG_UNSIGNED, "logical*4", (struct objfile *) NULL); 549 550 builtin_f_type->builtin_real = 551 init_type (TYPE_CODE_FLT, 552 gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT, 553 0, 554 "real", (struct objfile *) NULL); 555 556 builtin_f_type->builtin_real_s8 = 557 init_type (TYPE_CODE_FLT, 558 gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT, 559 0, 560 "real*8", (struct objfile *) NULL); 561 562 builtin_f_type->builtin_real_s16 = 563 init_type (TYPE_CODE_FLT, 564 gdbarch_long_double_bit (current_gdbarch) / TARGET_CHAR_BIT, 565 0, 566 "real*16", (struct objfile *) NULL); 567 568 builtin_f_type->builtin_complex_s8 = 569 init_type (TYPE_CODE_COMPLEX, 570 2 * gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT, 571 0, 572 "complex*8", (struct objfile *) NULL); 573 TYPE_TARGET_TYPE (builtin_f_type->builtin_complex_s8) 574 = builtin_f_type->builtin_real; 575 576 builtin_f_type->builtin_complex_s16 = 577 init_type (TYPE_CODE_COMPLEX, 578 2 * gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT, 579 0, 580 "complex*16", (struct objfile *) NULL); 581 TYPE_TARGET_TYPE (builtin_f_type->builtin_complex_s16) 582 = builtin_f_type->builtin_real_s8; 583 584 /* We have a new size == 4 double floats for the 585 complex*32 data type */ 586 587 builtin_f_type->builtin_complex_s32 = 588 init_type (TYPE_CODE_COMPLEX, 589 2 * gdbarch_long_double_bit (current_gdbarch) / TARGET_CHAR_BIT, 590 0, 591 "complex*32", (struct objfile *) NULL); 592 TYPE_TARGET_TYPE (builtin_f_type->builtin_complex_s32) 593 = builtin_f_type->builtin_real_s16; 594 595 return builtin_f_type; 596} 597 598static struct gdbarch_data *f_type_data; 599 600const struct builtin_f_type * 601builtin_f_type (struct gdbarch *gdbarch) 602{ 603 return gdbarch_data (gdbarch, f_type_data); 604} 605 606void 607_initialize_f_language (void) 608{ 609 f_type_data = gdbarch_data_register_post_init (build_fortran_types); 610 611 add_language (&f_language_defn); 612} 613 614#if 0 615static SAVED_BF_PTR 616allocate_saved_bf_node (void) 617{ 618 SAVED_BF_PTR new; 619 620 new = (SAVED_BF_PTR) xmalloc (sizeof (SAVED_BF)); 621 return (new); 622} 623 624static SAVED_FUNCTION * 625allocate_saved_function_node (void) 626{ 627 SAVED_FUNCTION *new; 628 629 new = (SAVED_FUNCTION *) xmalloc (sizeof (SAVED_FUNCTION)); 630 return (new); 631} 632 633static SAVED_F77_COMMON_PTR 634allocate_saved_f77_common_node (void) 635{ 636 SAVED_F77_COMMON_PTR new; 637 638 new = (SAVED_F77_COMMON_PTR) xmalloc (sizeof (SAVED_F77_COMMON)); 639 return (new); 640} 641 642static COMMON_ENTRY_PTR 643allocate_common_entry_node (void) 644{ 645 COMMON_ENTRY_PTR new; 646 647 new = (COMMON_ENTRY_PTR) xmalloc (sizeof (COMMON_ENTRY)); 648 return (new); 649} 650#endif 651 652SAVED_F77_COMMON_PTR head_common_list = NULL; /* Ptr to 1st saved COMMON */ 653SAVED_F77_COMMON_PTR tail_common_list = NULL; /* Ptr to last saved COMMON */ 654SAVED_F77_COMMON_PTR current_common = NULL; /* Ptr to current COMMON */ 655 656#if 0 657static SAVED_BF_PTR saved_bf_list = NULL; /* Ptr to (.bf,function) 658 list */ 659static SAVED_BF_PTR saved_bf_list_end = NULL; /* Ptr to above list's end */ 660static SAVED_BF_PTR current_head_bf_list = NULL; /* Current head of above list 661 */ 662 663static SAVED_BF_PTR tmp_bf_ptr; /* Generic temporary for use 664 in macros */ 665 666/* The following function simply enters a given common block onto 667 the global common block chain */ 668 669static void 670add_common_block (char *name, CORE_ADDR offset, int secnum, char *func_stab) 671{ 672 SAVED_F77_COMMON_PTR tmp; 673 char *c, *local_copy_func_stab; 674 675 /* If the COMMON block we are trying to add has a blank 676 name (i.e. "#BLNK_COM") then we set it to __BLANK 677 because the darn "#" character makes GDB's input 678 parser have fits. */ 679 680 681 if (strcmp (name, BLANK_COMMON_NAME_ORIGINAL) == 0 682 || strcmp (name, BLANK_COMMON_NAME_MF77) == 0) 683 { 684 685 xfree (name); 686 name = alloca (strlen (BLANK_COMMON_NAME_LOCAL) + 1); 687 strcpy (name, BLANK_COMMON_NAME_LOCAL); 688 } 689 690 tmp = allocate_saved_f77_common_node (); 691 692 local_copy_func_stab = xmalloc (strlen (func_stab) + 1); 693 strcpy (local_copy_func_stab, func_stab); 694 695 tmp->name = xmalloc (strlen (name) + 1); 696 697 /* local_copy_func_stab is a stabstring, let us first extract the 698 function name from the stab by NULLing out the ':' character. */ 699 700 701 c = NULL; 702 c = strchr (local_copy_func_stab, ':'); 703 704 if (c) 705 *c = '\0'; 706 else 707 error (_("Malformed function STAB found in add_common_block()")); 708 709 710 tmp->owning_function = xmalloc (strlen (local_copy_func_stab) + 1); 711 712 strcpy (tmp->owning_function, local_copy_func_stab); 713 714 strcpy (tmp->name, name); 715 tmp->offset = offset; 716 tmp->next = NULL; 717 tmp->entries = NULL; 718 tmp->secnum = secnum; 719 720 current_common = tmp; 721 722 if (head_common_list == NULL) 723 { 724 head_common_list = tail_common_list = tmp; 725 } 726 else 727 { 728 tail_common_list->next = tmp; 729 tail_common_list = tmp; 730 } 731} 732#endif 733 734/* The following function simply enters a given common entry onto 735 the "current_common" block that has been saved away. */ 736 737#if 0 738static void 739add_common_entry (struct symbol *entry_sym_ptr) 740{ 741 COMMON_ENTRY_PTR tmp; 742 743 744 745 /* The order of this list is important, since 746 we expect the entries to appear in decl. 747 order when we later issue "info common" calls */ 748 749 tmp = allocate_common_entry_node (); 750 751 tmp->next = NULL; 752 tmp->symbol = entry_sym_ptr; 753 754 if (current_common == NULL) 755 error (_("Attempt to add COMMON entry with no block open!")); 756 else 757 { 758 if (current_common->entries == NULL) 759 { 760 current_common->entries = tmp; 761 current_common->end_of_entries = tmp; 762 } 763 else 764 { 765 current_common->end_of_entries->next = tmp; 766 current_common->end_of_entries = tmp; 767 } 768 } 769} 770#endif 771 772/* This routine finds the first encountred COMMON block named "name" */ 773 774#if 0 775static SAVED_F77_COMMON_PTR 776find_first_common_named (char *name) 777{ 778 779 SAVED_F77_COMMON_PTR tmp; 780 781 tmp = head_common_list; 782 783 while (tmp != NULL) 784 { 785 if (strcmp (tmp->name, name) == 0) 786 return (tmp); 787 else 788 tmp = tmp->next; 789 } 790 return (NULL); 791} 792#endif 793 794/* This routine finds the first encountred COMMON block named "name" 795 that belongs to function funcname */ 796 797SAVED_F77_COMMON_PTR 798find_common_for_function (char *name, char *funcname) 799{ 800 801 SAVED_F77_COMMON_PTR tmp; 802 803 tmp = head_common_list; 804 805 while (tmp != NULL) 806 { 807 if (DEPRECATED_STREQ (tmp->name, name) 808 && DEPRECATED_STREQ (tmp->owning_function, funcname)) 809 return (tmp); 810 else 811 tmp = tmp->next; 812 } 813 return (NULL); 814} 815 816 817#if 0 818 819/* The following function is called to patch up the offsets 820 for the statics contained in the COMMON block named 821 "name." */ 822 823static void 824patch_common_entries (SAVED_F77_COMMON_PTR blk, CORE_ADDR offset, int secnum) 825{ 826 COMMON_ENTRY_PTR entry; 827 828 blk->offset = offset; /* Keep this around for future use. */ 829 830 entry = blk->entries; 831 832 while (entry != NULL) 833 { 834 SYMBOL_VALUE (entry->symbol) += offset; 835 SYMBOL_SECTION (entry->symbol) = secnum; 836 837 entry = entry->next; 838 } 839 blk->secnum = secnum; 840} 841 842/* Patch all commons named "name" that need patching.Since COMMON 843 blocks occur with relative infrequency, we simply do a linear scan on 844 the name. Eventually, the best way to do this will be a 845 hashed-lookup. Secnum is the section number for the .bss section 846 (which is where common data lives). */ 847 848static void 849patch_all_commons_by_name (char *name, CORE_ADDR offset, int secnum) 850{ 851 852 SAVED_F77_COMMON_PTR tmp; 853 854 /* For blank common blocks, change the canonical reprsentation 855 of a blank name */ 856 857 if (strcmp (name, BLANK_COMMON_NAME_ORIGINAL) == 0 858 || strcmp (name, BLANK_COMMON_NAME_MF77) == 0) 859 { 860 xfree (name); 861 name = alloca (strlen (BLANK_COMMON_NAME_LOCAL) + 1); 862 strcpy (name, BLANK_COMMON_NAME_LOCAL); 863 } 864 865 tmp = head_common_list; 866 867 while (tmp != NULL) 868 { 869 if (COMMON_NEEDS_PATCHING (tmp)) 870 if (strcmp (tmp->name, name) == 0) 871 patch_common_entries (tmp, offset, secnum); 872 873 tmp = tmp->next; 874 } 875} 876#endif 877 878/* This macro adds the symbol-number for the start of the function 879 (the symbol number of the .bf) referenced by symnum_fcn to a 880 list. This list, in reality should be a FIFO queue but since 881 #line pragmas sometimes cause line ranges to get messed up 882 we simply create a linear list. This list can then be searched 883 first by a queueing algorithm and upon failure fall back to 884 a linear scan. */ 885 886#if 0 887#define ADD_BF_SYMNUM(bf_sym,fcn_sym) \ 888 \ 889 if (saved_bf_list == NULL) \ 890{ \ 891 tmp_bf_ptr = allocate_saved_bf_node(); \ 892 \ 893 tmp_bf_ptr->symnum_bf = (bf_sym); \ 894 tmp_bf_ptr->symnum_fcn = (fcn_sym); \ 895 tmp_bf_ptr->next = NULL; \ 896 \ 897 current_head_bf_list = saved_bf_list = tmp_bf_ptr; \ 898 saved_bf_list_end = tmp_bf_ptr; \ 899 } \ 900else \ 901{ \ 902 tmp_bf_ptr = allocate_saved_bf_node(); \ 903 \ 904 tmp_bf_ptr->symnum_bf = (bf_sym); \ 905 tmp_bf_ptr->symnum_fcn = (fcn_sym); \ 906 tmp_bf_ptr->next = NULL; \ 907 \ 908 saved_bf_list_end->next = tmp_bf_ptr; \ 909 saved_bf_list_end = tmp_bf_ptr; \ 910 } 911#endif 912 913/* This function frees the entire (.bf,function) list */ 914 915#if 0 916static void 917clear_bf_list (void) 918{ 919 920 SAVED_BF_PTR tmp = saved_bf_list; 921 SAVED_BF_PTR next = NULL; 922 923 while (tmp != NULL) 924 { 925 next = tmp->next; 926 xfree (tmp); 927 tmp = next; 928 } 929 saved_bf_list = NULL; 930} 931#endif 932 933int global_remote_debug; 934 935#if 0 936 937static long 938get_bf_for_fcn (long the_function) 939{ 940 SAVED_BF_PTR tmp; 941 int nprobes = 0; 942 943 /* First use a simple queuing algorithm (i.e. look and see if the 944 item at the head of the queue is the one you want) */ 945 946 if (saved_bf_list == NULL) 947 internal_error (__FILE__, __LINE__, 948 _("cannot get .bf node off empty list")); 949 950 if (current_head_bf_list != NULL) 951 if (current_head_bf_list->symnum_fcn == the_function) 952 { 953 if (global_remote_debug) 954 fprintf_unfiltered (gdb_stderr, "*"); 955 956 tmp = current_head_bf_list; 957 current_head_bf_list = current_head_bf_list->next; 958 return (tmp->symnum_bf); 959 } 960 961 /* If the above did not work (probably because #line directives were 962 used in the sourcefile and they messed up our internal tables) we now do 963 the ugly linear scan */ 964 965 if (global_remote_debug) 966 fprintf_unfiltered (gdb_stderr, "\ndefaulting to linear scan\n"); 967 968 nprobes = 0; 969 tmp = saved_bf_list; 970 while (tmp != NULL) 971 { 972 nprobes++; 973 if (tmp->symnum_fcn == the_function) 974 { 975 if (global_remote_debug) 976 fprintf_unfiltered (gdb_stderr, "Found in %d probes\n", nprobes); 977 current_head_bf_list = tmp->next; 978 return (tmp->symnum_bf); 979 } 980 tmp = tmp->next; 981 } 982 983 return (-1); 984} 985 986static SAVED_FUNCTION_PTR saved_function_list = NULL; 987static SAVED_FUNCTION_PTR saved_function_list_end = NULL; 988 989static void 990clear_function_list (void) 991{ 992 SAVED_FUNCTION_PTR tmp = saved_function_list; 993 SAVED_FUNCTION_PTR next = NULL; 994 995 while (tmp != NULL) 996 { 997 next = tmp->next; 998 xfree (tmp); 999 tmp = next; 1000 } 1001 1002 saved_function_list = NULL; 1003} 1004#endif 1005