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
38 struct type *builtin_type_f_character;
39 struct type *builtin_type_f_logical;
40 struct type *builtin_type_f_logical_s1;
41 struct type *builtin_type_f_logical_s2;
42 struct type *builtin_type_f_integer;
43 struct type *builtin_type_f_integer_s2;
44 struct type *builtin_type_f_real;
45 struct type *builtin_type_f_real_s8;
46 struct type *builtin_type_f_real_s16;
47 struct type *builtin_type_f_complex_s8;
48 struct type *builtin_type_f_complex_s16;
49 struct type *builtin_type_f_complex_s32;
50 struct type *builtin_type_f_void;
51
52 /* Following is dubious stuff that had been in the xcoff reader. */
53
54 struct saved_fcn
55 {
56 long line_offset; /* Line offset for function */
57 struct saved_fcn *next;
58 };
59
60
61 struct 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
68 typedef struct saved_fcn SAVED_FUNCTION, *SAVED_FUNCTION_PTR;
69 typedef struct saved_bf_symnum SAVED_BF, *SAVED_BF_PTR;
70
71 /* Local functions */
72
73 extern void _initialize_f_language (void);
74 #if 0
75 static void clear_function_list (void);
76 static long get_bf_for_fcn (long);
77 static void clear_bf_list (void);
78 static void patch_all_commons_by_name (char *, CORE_ADDR, int);
79 static SAVED_F77_COMMON_PTR find_first_common_named (char *);
80 static void add_common_entry (struct symbol *);
81 static void add_common_block (char *, CORE_ADDR, int, char *);
82 static SAVED_FUNCTION *allocate_saved_function_node (void);
83 static SAVED_BF_PTR allocate_saved_bf_node (void);
84 static COMMON_ENTRY_PTR allocate_common_entry_node (void);
85 static SAVED_F77_COMMON_PTR allocate_saved_f77_common_node (void);
86 static void patch_common_entries (SAVED_F77_COMMON_PTR, CORE_ADDR, int);
87 #endif
88
89 static struct type *f_create_fundamental_type (struct objfile *, int);
90 static void f_printstr (struct ui_file * stream, char *string,
91 unsigned int length, int width,
92 int force_ellipses);
93 static void f_printchar (int c, struct ui_file * stream);
94 static 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
102 static void
f_emit_char(int c,struct ui_file * stream,int quoter)103 f_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
148 static void
f_printchar(int c,struct ui_file * stream)149 f_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
163 static void
f_printstr(struct ui_file * stream,char * string,unsigned int length,int width,int force_ellipses)164 f_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
250 static struct type *
f_create_fundamental_type(struct objfile * objfile,int typeid)251 f_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
407 static 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
432 struct 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. */
454 extern int c_value_print (struct value *, struct ui_file *, int,
455 enum val_prettyprint);
456
457 const 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 array_column_major,
466 &exp_descriptor_standard,
467 f_parse, /* parser */
468 f_error, /* parser error function */
469 null_post_parser,
470 f_printchar, /* Print character constant */
471 f_printstr, /* function to print string constant */
472 f_emit_char, /* Function to print a single character */
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 NULL, /* Language specific skip_trampoline */
478 value_of_this, /* value_of_this */
479 basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
480 basic_lookup_transparent_type,/* lookup_transparent_type */
481 NULL, /* Language specific symbol demangler */
482 NULL, /* Language specific class_name_from_physname */
483 f_op_print_tab, /* expression operators for printing */
484 0, /* arrays are first-class (not c-style) */
485 1, /* String lower bound */
486 &builtin_type_f_character, /* Type of string elements */
487 default_word_break_characters,
488 NULL, /* FIXME: la_language_arch_info. */
489 LANG_MAGIC
490 };
491
492 static void
build_fortran_types(void)493 build_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
567 void
_initialize_f_language(void)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
597 static SAVED_BF_PTR
598 allocate_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
606 static SAVED_FUNCTION *
607 allocate_saved_function_node (void)
608 {
609 SAVED_FUNCTION *new;
610
611 new = (SAVED_FUNCTION *) xmalloc (sizeof (SAVED_FUNCTION));
612 return (new);
613 }
614
615 static SAVED_F77_COMMON_PTR
616 allocate_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
624 static COMMON_ENTRY_PTR
625 allocate_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
634 SAVED_F77_COMMON_PTR head_common_list = NULL; /* Ptr to 1st saved COMMON */
635 SAVED_F77_COMMON_PTR tail_common_list = NULL; /* Ptr to last saved COMMON */
636 SAVED_F77_COMMON_PTR current_common = NULL; /* Ptr to current COMMON */
637
638 #if 0
639 static SAVED_BF_PTR saved_bf_list = NULL; /* Ptr to (.bf,function)
640 list */
641 static SAVED_BF_PTR saved_bf_list_end = NULL; /* Ptr to above list's end */
642 static SAVED_BF_PTR current_head_bf_list = NULL; /* Current head of above list
643 */
644
645 static 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
651 static void
652 add_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
720 static void
721 add_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
757 static SAVED_F77_COMMON_PTR
758 find_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
779 SAVED_F77_COMMON_PTR
find_common_for_function(char * name,char * funcname)780 find_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
805 static void
806 patch_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
830 static void
831 patch_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 } \
882 else \
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
898 static void
899 clear_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
915 int global_remote_debug;
916
917 #if 0
918
919 static long
920 get_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
968 static SAVED_FUNCTION_PTR saved_function_list = NULL;
969 static SAVED_FUNCTION_PTR saved_function_list_end = NULL;
970
971 static void
972 clear_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