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