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