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