gdb: Convert language la_lookup_transparent_type field to a method
[deliverable/binutils-gdb.git] / gdb / f-lang.c
CommitLineData
c906108c 1/* Fortran language support routines for GDB, the GNU debugger.
ce27fb25 2
b811d2c2 3 Copyright (C) 1993-2020 Free Software Foundation, Inc.
ce27fb25 4
c906108c
SS
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
7
c5aa993b 8 This file is part of GDB.
c906108c 9
c5aa993b
JM
10 This program is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
a9762ec7 12 the Free Software Foundation; either version 3 of the License, or
c5aa993b 13 (at your option) any later version.
c906108c 14
c5aa993b
JM
15 This program is distributed in the hope that it will be useful,
16 but WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 GNU General Public License for more details.
c906108c 19
c5aa993b 20 You should have received a copy of the GNU General Public License
a9762ec7 21 along with this program. If not, see <http://www.gnu.org/licenses/>. */
c906108c
SS
22
23#include "defs.h"
4de283e4 24#include "symtab.h"
d55e5aa6 25#include "gdbtypes.h"
4de283e4 26#include "expression.h"
d55e5aa6 27#include "parser-defs.h"
4de283e4
TT
28#include "language.h"
29#include "varobj.h"
30#include "gdbcore.h"
31#include "f-lang.h"
745b8ca0 32#include "valprint.h"
5f9a71c3 33#include "value.h"
4de283e4
TT
34#include "cp-support.h"
35#include "charset.h"
36#include "c-lang.h"
37#include "target-float.h"
0d12e84c 38#include "gdbarch.h"
4de283e4
TT
39
40#include <math.h>
c906108c 41
c906108c
SS
42/* Local functions */
43
6c7a06a3
TT
44static void f_printchar (int c, struct type *type, struct ui_file * stream);
45static void f_emit_char (int c, struct type *type,
46 struct ui_file * stream, int quoter);
c906108c 47
3b2b8fea
TT
48/* Return the encoding that should be used for the character type
49 TYPE. */
50
51static const char *
52f_get_encoding (struct type *type)
53{
54 const char *encoding;
55
56 switch (TYPE_LENGTH (type))
57 {
58 case 1:
59 encoding = target_charset (get_type_arch (type));
60 break;
61 case 4:
34877895 62 if (type_byte_order (type) == BFD_ENDIAN_BIG)
3b2b8fea
TT
63 encoding = "UTF-32BE";
64 else
65 encoding = "UTF-32LE";
66 break;
67
68 default:
69 error (_("unrecognized character type"));
70 }
71
72 return encoding;
73}
74
c906108c
SS
75/* Print the character C on STREAM as part of the contents of a literal
76 string whose delimiter is QUOTER. Note that that format for printing
77 characters and strings is language specific.
78 FIXME: This is a copy of the same function from c-exp.y. It should
79 be replaced with a true F77 version. */
80
81static void
6c7a06a3 82f_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
c906108c 83{
3b2b8fea 84 const char *encoding = f_get_encoding (type);
c5aa993b 85
3b2b8fea 86 generic_emit_char (c, type, stream, quoter, encoding);
c906108c
SS
87}
88
3b2b8fea 89/* Implementation of la_printchar. */
c906108c
SS
90
91static void
6c7a06a3 92f_printchar (int c, struct type *type, struct ui_file *stream)
c906108c
SS
93{
94 fputs_filtered ("'", stream);
6c7a06a3 95 LA_EMIT_CHAR (c, type, stream, '\'');
c906108c
SS
96 fputs_filtered ("'", stream);
97}
98
99/* Print the character string STRING, printing at most LENGTH characters.
100 Printing stops early if the number hits print_max; repeat counts
101 are printed as appropriate. Print ellipses at the end if we
102 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
103 FIXME: This is a copy of the same function from c-exp.y. It should
0963b4bd 104 be replaced with a true F77 version. */
c906108c
SS
105
106static void
6c7a06a3 107f_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
be759fcf 108 unsigned int length, const char *encoding, int force_ellipses,
79a45b7d 109 const struct value_print_options *options)
c906108c 110{
3b2b8fea 111 const char *type_encoding = f_get_encoding (type);
c5aa993b 112
3b2b8fea
TT
113 if (TYPE_LENGTH (type) == 4)
114 fputs_filtered ("4_", stream);
c5aa993b 115
3b2b8fea
TT
116 if (!encoding || !*encoding)
117 encoding = type_encoding;
c5aa993b 118
3b2b8fea
TT
119 generic_printstr (stream, type, string, length, encoding,
120 force_ellipses, '\'', 0, options);
c906108c 121}
c906108c 122\f
c5aa993b 123
c906108c
SS
124/* Table of operators and their precedences for printing expressions. */
125
c5aa993b
JM
126static const struct op_print f_op_print_tab[] =
127{
128 {"+", BINOP_ADD, PREC_ADD, 0},
129 {"+", UNOP_PLUS, PREC_PREFIX, 0},
130 {"-", BINOP_SUB, PREC_ADD, 0},
131 {"-", UNOP_NEG, PREC_PREFIX, 0},
132 {"*", BINOP_MUL, PREC_MUL, 0},
133 {"/", BINOP_DIV, PREC_MUL, 0},
134 {"DIV", BINOP_INTDIV, PREC_MUL, 0},
135 {"MOD", BINOP_REM, PREC_MUL, 0},
136 {"=", BINOP_ASSIGN, PREC_ASSIGN, 1},
137 {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
138 {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
139 {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
140 {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0},
141 {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0},
142 {".LE.", BINOP_LEQ, PREC_ORDER, 0},
143 {".GE.", BINOP_GEQ, PREC_ORDER, 0},
144 {".GT.", BINOP_GTR, PREC_ORDER, 0},
145 {".LT.", BINOP_LESS, PREC_ORDER, 0},
146 {"**", UNOP_IND, PREC_PREFIX, 0},
147 {"@", BINOP_REPEAT, PREC_REPEAT, 0},
f486487f 148 {NULL, OP_NULL, PREC_REPEAT, 0}
c906108c
SS
149};
150\f
cad351d1
UW
151enum f_primitive_types {
152 f_primitive_type_character,
153 f_primitive_type_logical,
154 f_primitive_type_logical_s1,
155 f_primitive_type_logical_s2,
ce4b0682 156 f_primitive_type_logical_s8,
cad351d1
UW
157 f_primitive_type_integer,
158 f_primitive_type_integer_s2,
159 f_primitive_type_real,
160 f_primitive_type_real_s8,
161 f_primitive_type_real_s16,
162 f_primitive_type_complex_s8,
163 f_primitive_type_complex_s16,
164 f_primitive_type_void,
165 nr_f_primitive_types
c906108c
SS
166};
167
f55ee35c
JK
168/* Remove the modules separator :: from the default break list. */
169
67cb5b2d 170static const char *
f55ee35c
JK
171f_word_break_characters (void)
172{
173 static char *retval;
174
175 if (!retval)
176 {
177 char *s;
178
179 retval = xstrdup (default_word_break_characters ());
180 s = strchr (retval, ':');
181 if (s)
182 {
183 char *last_char = &s[strlen (s) - 1];
184
185 *s = *last_char;
186 *last_char = 0;
187 }
188 }
189 return retval;
190}
191
3e43a32a
MS
192/* Consider the modules separator :: as a valid symbol name character
193 class. */
f55ee35c 194
eb3ff9a5
PA
195static void
196f_collect_symbol_completion_matches (completion_tracker &tracker,
c6756f62 197 complete_symbol_mode mode,
b5ec771e 198 symbol_name_match_type compare_name,
eb3ff9a5
PA
199 const char *text, const char *word,
200 enum type_code code)
f55ee35c 201{
c6756f62 202 default_collect_symbol_completion_matches_break_on (tracker, mode,
b5ec771e 203 compare_name,
eb3ff9a5 204 text, word, ":", code);
f55ee35c
JK
205}
206
9dad4a58 207/* Special expression evaluation cases for Fortran. */
cb8c24b6
SM
208
209static struct value *
9dad4a58
AB
210evaluate_subexp_f (struct type *expect_type, struct expression *exp,
211 int *pos, enum noside noside)
212{
b6d03bb2 213 struct value *arg1 = NULL, *arg2 = NULL;
4d00f5d8
AB
214 enum exp_opcode op;
215 int pc;
216 struct type *type;
217
218 pc = *pos;
219 *pos += 1;
220 op = exp->elts[pc].opcode;
221
222 switch (op)
223 {
224 default:
225 *pos -= 1;
226 return evaluate_subexp_standard (expect_type, exp, pos, noside);
227
0841c79a
AB
228 case UNOP_ABS:
229 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
230 if (noside == EVAL_SKIP)
231 return eval_skip_value (exp);
232 type = value_type (arg1);
78134374 233 switch (type->code ())
0841c79a
AB
234 {
235 case TYPE_CODE_FLT:
236 {
237 double d
238 = fabs (target_float_to_host_double (value_contents (arg1),
239 value_type (arg1)));
240 return value_from_host_double (type, d);
241 }
242 case TYPE_CODE_INT:
243 {
244 LONGEST l = value_as_long (arg1);
245 l = llabs (l);
246 return value_from_longest (type, l);
247 }
248 }
249 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type));
250
b6d03bb2
AB
251 case BINOP_MOD:
252 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
253 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
254 if (noside == EVAL_SKIP)
255 return eval_skip_value (exp);
256 type = value_type (arg1);
78134374 257 if (type->code () != value_type (arg2)->code ())
b6d03bb2 258 error (_("non-matching types for parameters to MOD ()"));
78134374 259 switch (type->code ())
b6d03bb2
AB
260 {
261 case TYPE_CODE_FLT:
262 {
263 double d1
264 = target_float_to_host_double (value_contents (arg1),
265 value_type (arg1));
266 double d2
267 = target_float_to_host_double (value_contents (arg2),
268 value_type (arg2));
269 double d3 = fmod (d1, d2);
270 return value_from_host_double (type, d3);
271 }
272 case TYPE_CODE_INT:
273 {
274 LONGEST v1 = value_as_long (arg1);
275 LONGEST v2 = value_as_long (arg2);
276 if (v2 == 0)
277 error (_("calling MOD (N, 0) is undefined"));
278 LONGEST v3 = v1 - (v1 / v2) * v2;
279 return value_from_longest (value_type (arg1), v3);
280 }
281 }
282 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type));
283
284 case UNOP_FORTRAN_CEILING:
285 {
286 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
287 if (noside == EVAL_SKIP)
288 return eval_skip_value (exp);
289 type = value_type (arg1);
78134374 290 if (type->code () != TYPE_CODE_FLT)
b6d03bb2
AB
291 error (_("argument to CEILING must be of type float"));
292 double val
293 = target_float_to_host_double (value_contents (arg1),
294 value_type (arg1));
295 val = ceil (val);
296 return value_from_host_double (type, val);
297 }
298
299 case UNOP_FORTRAN_FLOOR:
300 {
301 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
302 if (noside == EVAL_SKIP)
303 return eval_skip_value (exp);
304 type = value_type (arg1);
78134374 305 if (type->code () != TYPE_CODE_FLT)
b6d03bb2
AB
306 error (_("argument to FLOOR must be of type float"));
307 double val
308 = target_float_to_host_double (value_contents (arg1),
309 value_type (arg1));
310 val = floor (val);
311 return value_from_host_double (type, val);
312 }
313
314 case BINOP_FORTRAN_MODULO:
315 {
316 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
317 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
318 if (noside == EVAL_SKIP)
319 return eval_skip_value (exp);
320 type = value_type (arg1);
78134374 321 if (type->code () != value_type (arg2)->code ())
b6d03bb2
AB
322 error (_("non-matching types for parameters to MODULO ()"));
323 /* MODULO(A, P) = A - FLOOR (A / P) * P */
78134374 324 switch (type->code ())
b6d03bb2
AB
325 {
326 case TYPE_CODE_INT:
327 {
328 LONGEST a = value_as_long (arg1);
329 LONGEST p = value_as_long (arg2);
330 LONGEST result = a - (a / p) * p;
331 if (result != 0 && (a < 0) != (p < 0))
332 result += p;
333 return value_from_longest (value_type (arg1), result);
334 }
335 case TYPE_CODE_FLT:
336 {
337 double a
338 = target_float_to_host_double (value_contents (arg1),
339 value_type (arg1));
340 double p
341 = target_float_to_host_double (value_contents (arg2),
342 value_type (arg2));
343 double result = fmod (a, p);
344 if (result != 0 && (a < 0.0) != (p < 0.0))
345 result += p;
346 return value_from_host_double (type, result);
347 }
348 }
349 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type));
350 }
351
352 case BINOP_FORTRAN_CMPLX:
353 arg1 = evaluate_subexp (NULL_TYPE, exp, pos, noside);
354 arg2 = evaluate_subexp (value_type (arg1), exp, pos, noside);
355 if (noside == EVAL_SKIP)
356 return eval_skip_value (exp);
357 type = builtin_f_type(exp->gdbarch)->builtin_complex_s16;
358 return value_literal_complex (arg1, arg2, type);
359
83228e93 360 case UNOP_FORTRAN_KIND:
4d00f5d8
AB
361 arg1 = evaluate_subexp (NULL, exp, pos, EVAL_AVOID_SIDE_EFFECTS);
362 type = value_type (arg1);
363
78134374 364 switch (type->code ())
4d00f5d8
AB
365 {
366 case TYPE_CODE_STRUCT:
367 case TYPE_CODE_UNION:
368 case TYPE_CODE_MODULE:
369 case TYPE_CODE_FUNC:
370 error (_("argument to kind must be an intrinsic type"));
371 }
372
373 if (!TYPE_TARGET_TYPE (type))
374 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
375 TYPE_LENGTH (type));
376 return value_from_longest (builtin_type (exp->gdbarch)->builtin_int,
78134374 377 TYPE_LENGTH (TYPE_TARGET_TYPE (type)));
4d00f5d8
AB
378 }
379
380 /* Should be unreachable. */
381 return nullptr;
9dad4a58
AB
382}
383
4be290b2
AB
384/* Return true if TYPE is a string. */
385
386static bool
387f_is_string_type_p (struct type *type)
388{
389 type = check_typedef (type);
78134374
SM
390 return (type->code () == TYPE_CODE_STRING
391 || (type->code () == TYPE_CODE_ARRAY
392 && TYPE_TARGET_TYPE (type)->code () == TYPE_CODE_CHAR));
4be290b2
AB
393}
394
83228e93
AB
395/* Special expression lengths for Fortran. */
396
397static void
398operator_length_f (const struct expression *exp, int pc, int *oplenp,
399 int *argsp)
400{
401 int oplen = 1;
402 int args = 0;
403
404 switch (exp->elts[pc - 1].opcode)
405 {
406 default:
407 operator_length_standard (exp, pc, oplenp, argsp);
408 return;
409
410 case UNOP_FORTRAN_KIND:
b6d03bb2
AB
411 case UNOP_FORTRAN_FLOOR:
412 case UNOP_FORTRAN_CEILING:
83228e93
AB
413 oplen = 1;
414 args = 1;
415 break;
b6d03bb2
AB
416
417 case BINOP_FORTRAN_CMPLX:
418 case BINOP_FORTRAN_MODULO:
419 oplen = 1;
420 args = 2;
421 break;
83228e93
AB
422 }
423
424 *oplenp = oplen;
425 *argsp = args;
426}
427
b6d03bb2
AB
428/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
429 the extra argument NAME which is the text that should be printed as the
430 name of this operation. */
431
432static void
433print_unop_subexp_f (struct expression *exp, int *pos,
434 struct ui_file *stream, enum precedence prec,
435 const char *name)
436{
437 (*pos)++;
438 fprintf_filtered (stream, "%s(", name);
439 print_subexp (exp, pos, stream, PREC_SUFFIX);
440 fputs_filtered (")", stream);
441}
442
443/* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
444 the extra argument NAME which is the text that should be printed as the
445 name of this operation. */
446
447static void
448print_binop_subexp_f (struct expression *exp, int *pos,
449 struct ui_file *stream, enum precedence prec,
450 const char *name)
451{
452 (*pos)++;
453 fprintf_filtered (stream, "%s(", name);
454 print_subexp (exp, pos, stream, PREC_SUFFIX);
455 fputs_filtered (",", stream);
456 print_subexp (exp, pos, stream, PREC_SUFFIX);
457 fputs_filtered (")", stream);
458}
459
83228e93
AB
460/* Special expression printing for Fortran. */
461
462static void
463print_subexp_f (struct expression *exp, int *pos,
464 struct ui_file *stream, enum precedence prec)
465{
466 int pc = *pos;
467 enum exp_opcode op = exp->elts[pc].opcode;
468
469 switch (op)
470 {
471 default:
472 print_subexp_standard (exp, pos, stream, prec);
473 return;
474
475 case UNOP_FORTRAN_KIND:
b6d03bb2
AB
476 print_unop_subexp_f (exp, pos, stream, prec, "KIND");
477 return;
478
479 case UNOP_FORTRAN_FLOOR:
480 print_unop_subexp_f (exp, pos, stream, prec, "FLOOR");
481 return;
482
483 case UNOP_FORTRAN_CEILING:
484 print_unop_subexp_f (exp, pos, stream, prec, "CEILING");
485 return;
486
487 case BINOP_FORTRAN_CMPLX:
488 print_binop_subexp_f (exp, pos, stream, prec, "CMPLX");
489 return;
490
491 case BINOP_FORTRAN_MODULO:
492 print_binop_subexp_f (exp, pos, stream, prec, "MODULO");
83228e93
AB
493 return;
494 }
495}
496
497/* Special expression names for Fortran. */
498
499static const char *
500op_name_f (enum exp_opcode opcode)
501{
502 switch (opcode)
503 {
504 default:
505 return op_name_standard (opcode);
506
507#define OP(name) \
508 case name: \
509 return #name ;
510#include "fortran-operator.def"
511#undef OP
512 }
513}
514
515/* Special expression dumping for Fortran. */
516
517static int
518dump_subexp_body_f (struct expression *exp,
519 struct ui_file *stream, int elt)
520{
521 int opcode = exp->elts[elt].opcode;
522 int oplen, nargs, i;
523
524 switch (opcode)
525 {
526 default:
527 return dump_subexp_body_standard (exp, stream, elt);
528
529 case UNOP_FORTRAN_KIND:
b6d03bb2
AB
530 case UNOP_FORTRAN_FLOOR:
531 case UNOP_FORTRAN_CEILING:
532 case BINOP_FORTRAN_CMPLX:
533 case BINOP_FORTRAN_MODULO:
83228e93
AB
534 operator_length_f (exp, (elt + 1), &oplen, &nargs);
535 break;
536 }
537
538 elt += oplen;
539 for (i = 0; i < nargs; i += 1)
540 elt = dump_subexp (exp, stream, elt);
541
542 return elt;
543}
544
545/* Special expression checking for Fortran. */
546
547static int
548operator_check_f (struct expression *exp, int pos,
549 int (*objfile_func) (struct objfile *objfile,
550 void *data),
551 void *data)
552{
553 const union exp_element *const elts = exp->elts;
554
555 switch (elts[pos].opcode)
556 {
557 case UNOP_FORTRAN_KIND:
b6d03bb2
AB
558 case UNOP_FORTRAN_FLOOR:
559 case UNOP_FORTRAN_CEILING:
560 case BINOP_FORTRAN_CMPLX:
561 case BINOP_FORTRAN_MODULO:
83228e93
AB
562 /* Any references to objfiles are held in the arguments to this
563 expression, not within the expression itself, so no additional
564 checking is required here, the outer expression iteration code
565 will take care of checking each argument. */
566 break;
567
568 default:
569 return operator_check_standard (exp, pos, objfile_func, data);
570 }
571
572 return 0;
573}
574
56618e20
TT
575static const char *f_extensions[] =
576{
577 ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
578 ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
579 NULL
580};
581
9dad4a58
AB
582/* Expression processing for Fortran. */
583static const struct exp_descriptor exp_descriptor_f =
584{
83228e93
AB
585 print_subexp_f,
586 operator_length_f,
587 operator_check_f,
588 op_name_f,
589 dump_subexp_body_f,
9dad4a58
AB
590 evaluate_subexp_f
591};
592
0874fd07
AB
593/* Constant data that describes the Fortran language. */
594
595extern const struct language_data f_language_data =
c5aa993b 596{
c906108c 597 "fortran",
6abde28f 598 "Fortran",
c906108c 599 language_fortran,
c906108c 600 range_check_on,
63872f9d 601 case_sensitive_off,
7ca2d3a3 602 array_column_major,
9a044a89 603 macro_expansion_no,
56618e20 604 f_extensions,
9dad4a58 605 &exp_descriptor_f,
c906108c 606 f_parse, /* parser */
e85c3284 607 null_post_parser,
c906108c
SS
608 f_printchar, /* Print character constant */
609 f_printstr, /* function to print string constant */
610 f_emit_char, /* Function to print a single character */
c5aa993b 611 f_print_type, /* Print a type using appropriate syntax */
1f20c35e 612 f_print_typedef, /* Print a typedef using appropriate syntax */
24051bbe 613 f_value_print_innner, /* la_value_print_inner */
c5aa993b 614 c_value_print, /* FIXME */
f636b87d 615 NULL, /* Language specific skip_trampoline */
2b2d9e11 616 NULL, /* name_of_this */
59cc4834 617 false, /* la_store_sym_names_in_linkage_form_p */
f55ee35c 618 cp_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
8b302db8
TT
619
620 /* We could support demangling here to provide module namespaces
621 also for inferiors with only minimal symbol table (ELF symbols).
622 Just the mangling standard is not standardized across compilers
623 and there is no DW_AT_producer available for inferiors with only
624 the ELF symbols to check the mangling kind. */
9a3d7dfd 625 NULL, /* Language specific symbol demangler */
8b302db8 626 NULL,
3e43a32a
MS
627 NULL, /* Language specific
628 class_name_from_physname */
c906108c
SS
629 f_op_print_tab, /* expression operators for printing */
630 0, /* arrays are first-class (not c-style) */
631 1, /* String lower bound */
f55ee35c 632 f_word_break_characters,
eb3ff9a5 633 f_collect_symbol_completion_matches,
43cc5389 634 c_watch_location_expression,
179aed7f 635 cp_get_symbol_name_matcher, /* la_get_symbol_name_matcher */
f8eba3c6 636 iterate_over_symbols,
179aed7f 637 cp_search_name_hash,
a53b64ea 638 &default_varobj_ops,
bb2ec1b3 639 NULL,
721b08c6 640 NULL,
4be290b2 641 f_is_string_type_p,
721b08c6 642 "(...)" /* la_struct_too_deep_ellipsis */
c5aa993b 643};
c906108c 644
0874fd07
AB
645/* Class representing the Fortran language. */
646
647class f_language : public language_defn
648{
649public:
650 f_language ()
651 : language_defn (language_fortran, f_language_data)
652 { /* Nothing. */ }
1fb314aa
AB
653
654 /* See language.h. */
655 void language_arch_info (struct gdbarch *gdbarch,
656 struct language_arch_info *lai) const override
657 {
658 const struct builtin_f_type *builtin = builtin_f_type (gdbarch);
659
660 lai->string_char_type = builtin->builtin_character;
661 lai->primitive_type_vector
662 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1,
663 struct type *);
664
665 lai->primitive_type_vector [f_primitive_type_character]
666 = builtin->builtin_character;
667 lai->primitive_type_vector [f_primitive_type_logical]
668 = builtin->builtin_logical;
669 lai->primitive_type_vector [f_primitive_type_logical_s1]
670 = builtin->builtin_logical_s1;
671 lai->primitive_type_vector [f_primitive_type_logical_s2]
672 = builtin->builtin_logical_s2;
673 lai->primitive_type_vector [f_primitive_type_logical_s8]
674 = builtin->builtin_logical_s8;
675 lai->primitive_type_vector [f_primitive_type_real]
676 = builtin->builtin_real;
677 lai->primitive_type_vector [f_primitive_type_real_s8]
678 = builtin->builtin_real_s8;
679 lai->primitive_type_vector [f_primitive_type_real_s16]
680 = builtin->builtin_real_s16;
681 lai->primitive_type_vector [f_primitive_type_complex_s8]
682 = builtin->builtin_complex_s8;
683 lai->primitive_type_vector [f_primitive_type_complex_s16]
684 = builtin->builtin_complex_s16;
685 lai->primitive_type_vector [f_primitive_type_void]
686 = builtin->builtin_void;
687
688 lai->bool_type_symbol = "logical";
689 lai->bool_type_default = builtin->builtin_logical_s2;
690 }
0874fd07
AB
691};
692
693/* Single instance of the Fortran language class. */
694
695static f_language f_language_defn;
696
54ef06c7
UW
697static void *
698build_fortran_types (struct gdbarch *gdbarch)
c906108c 699{
54ef06c7
UW
700 struct builtin_f_type *builtin_f_type
701 = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
702
e9bb382b 703 builtin_f_type->builtin_void
bbe75b9d 704 = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "void");
e9bb382b
UW
705
706 builtin_f_type->builtin_character
4a270568 707 = arch_type (gdbarch, TYPE_CODE_CHAR, TARGET_CHAR_BIT, "character");
e9bb382b
UW
708
709 builtin_f_type->builtin_logical_s1
710 = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
711
712 builtin_f_type->builtin_integer_s2
713 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
714 "integer*2");
715
067630bd
AB
716 builtin_f_type->builtin_integer_s8
717 = arch_integer_type (gdbarch, gdbarch_long_long_bit (gdbarch), 0,
718 "integer*8");
719
e9bb382b
UW
720 builtin_f_type->builtin_logical_s2
721 = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
722 "logical*2");
723
ce4b0682
SDJ
724 builtin_f_type->builtin_logical_s8
725 = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
726 "logical*8");
727
e9bb382b
UW
728 builtin_f_type->builtin_integer
729 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
730 "integer");
731
732 builtin_f_type->builtin_logical
733 = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
734 "logical*4");
735
736 builtin_f_type->builtin_real
737 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
49f190bc 738 "real", gdbarch_float_format (gdbarch));
e9bb382b
UW
739 builtin_f_type->builtin_real_s8
740 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
49f190bc 741 "real*8", gdbarch_double_format (gdbarch));
34d11c68 742 auto fmt = gdbarch_floatformat_for_type (gdbarch, "real(kind=16)", 128);
dc42e902
AB
743 if (fmt != nullptr)
744 builtin_f_type->builtin_real_s16
745 = arch_float_type (gdbarch, 128, "real*16", fmt);
746 else if (gdbarch_long_double_bit (gdbarch) == 128)
747 builtin_f_type->builtin_real_s16
748 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
749 "real*16", gdbarch_long_double_format (gdbarch));
750 else
751 builtin_f_type->builtin_real_s16
752 = arch_type (gdbarch, TYPE_CODE_ERROR, 128, "real*16");
e9bb382b
UW
753
754 builtin_f_type->builtin_complex_s8
5b930b45 755 = init_complex_type ("complex*8", builtin_f_type->builtin_real);
e9bb382b 756 builtin_f_type->builtin_complex_s16
5b930b45 757 = init_complex_type ("complex*16", builtin_f_type->builtin_real_s8);
0830d301 758
78134374 759 if (builtin_f_type->builtin_real_s16->code () == TYPE_CODE_ERROR)
0830d301
TT
760 builtin_f_type->builtin_complex_s32
761 = arch_type (gdbarch, TYPE_CODE_ERROR, 256, "complex*32");
762 else
763 builtin_f_type->builtin_complex_s32
764 = init_complex_type ("complex*32", builtin_f_type->builtin_real_s16);
54ef06c7
UW
765
766 return builtin_f_type;
767}
768
769static struct gdbarch_data *f_type_data;
770
771const struct builtin_f_type *
772builtin_f_type (struct gdbarch *gdbarch)
773{
9a3c8263 774 return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
4e845cd3
MS
775}
776
6c265988 777void _initialize_f_language ();
4e845cd3 778void
6c265988 779_initialize_f_language ()
4e845cd3 780{
54ef06c7 781 f_type_data = gdbarch_data_register_post_init (build_fortran_types);
c906108c 782}
aa3cfbda
RB
783
784/* See f-lang.h. */
785
786struct value *
787fortran_argument_convert (struct value *value, bool is_artificial)
788{
789 if (!is_artificial)
790 {
791 /* If the value is not in the inferior e.g. registers values,
792 convenience variables and user input. */
793 if (VALUE_LVAL (value) != lval_memory)
794 {
795 struct type *type = value_type (value);
796 const int length = TYPE_LENGTH (type);
797 const CORE_ADDR addr
798 = value_as_long (value_allocate_space_in_inferior (length));
799 write_memory (addr, value_contents (value), length);
800 struct value *val
801 = value_from_contents_and_address (type, value_contents (value),
802 addr);
803 return value_addr (val);
804 }
805 else
806 return value_addr (value); /* Program variables, e.g. arrays. */
807 }
808 return value;
809}
810
811/* See f-lang.h. */
812
813struct type *
814fortran_preserve_arg_pointer (struct value *arg, struct type *type)
815{
78134374 816 if (value_type (arg)->code () == TYPE_CODE_PTR)
aa3cfbda
RB
817 return value_type (arg);
818 return type;
819}
This page took 1.496893 seconds and 4 git commands to generate.