xref: /openbsd-src/gnu/usr.bin/binutils/gdb/f-lang.c (revision e93f7393d476ad1c5192174ea92f14ecc97182e7)
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