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