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