gdb/f-lang.c

   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 \f
 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 \f
 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