1 /* Fortran language support routines for GDB, the GNU debugger.
3 Copyright (C) 1993-2020 Free Software Foundation, Inc.
5 Contributed by Motorola. Adapted from the C parser by Farooq Butt
6 (fmbutt@engage.sps.mot.com).
8 This file is part of GDB.
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.
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.
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/>. */
26 #include "expression.h"
27 #include "parser-defs.h"
34 #include "cp-support.h"
37 #include "target-float.h"
44 /* Return the encoding that should be used for the character type
48 f_language::get_encoding (struct type
*type
)
52 switch (TYPE_LENGTH (type
))
55 encoding
= target_charset (get_type_arch (type
));
58 if (type_byte_order (type
) == BFD_ENDIAN_BIG
)
59 encoding
= "UTF-32BE";
61 encoding
= "UTF-32LE";
65 error (_("unrecognized character type"));
73 /* Table of operators and their precedences for printing expressions. */
75 const struct op_print
f_language::op_print_tab
[] =
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}
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
,
117 /* Called from fortran_value_subarray to take a slice of an array or a
118 string. ARRAY is the array or string to be accessed. EXP, POS, and
119 NOSIDE are as for evaluate_subexp_standard. Return a value that is a
120 slice of the array. */
122 static struct value
*
123 value_f90_subarray (struct value
*array
,
124 struct expression
*exp
, int *pos
, enum noside noside
)
127 LONGEST low_bound
, high_bound
, stride
;
128 struct type
*range
= check_typedef (value_type (array
)->index_type ());
129 enum range_flag range_flag
130 = (enum range_flag
) longest_to_int (exp
->elts
[pc
].longconst
);
134 if (range_flag
& RANGE_LOW_BOUND_DEFAULT
)
135 low_bound
= range
->bounds ()->low
.const_val ();
137 low_bound
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
139 if (range_flag
& RANGE_HIGH_BOUND_DEFAULT
)
140 high_bound
= range
->bounds ()->high
.const_val ();
142 high_bound
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
144 if (range_flag
& RANGE_HAS_STRIDE
)
145 stride
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
150 error (_("Fortran array strides are not currently supported"));
152 return value_slice (array
, low_bound
, high_bound
- low_bound
+ 1);
155 /* Helper for skipping all the arguments in an undetermined argument list.
156 This function was designed for use in the OP_F77_UNDETERMINED_ARGLIST
157 case of evaluate_subexp_standard as multiple, but not all, code paths
158 require a generic skip. */
161 skip_undetermined_arglist (int nargs
, struct expression
*exp
, int *pos
,
164 for (int i
= 0; i
< nargs
; ++i
)
165 evaluate_subexp (nullptr, exp
, pos
, noside
);
168 /* Return the number of dimensions for a Fortran array or string. */
171 calc_f77_array_dims (struct type
*array_type
)
174 struct type
*tmp_type
;
176 if ((array_type
->code () == TYPE_CODE_STRING
))
179 if ((array_type
->code () != TYPE_CODE_ARRAY
))
180 error (_("Can't get dimensions for a non-array type"));
182 tmp_type
= array_type
;
184 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
186 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
192 /* Called from evaluate_subexp_standard to perform array indexing, and
193 sub-range extraction, for Fortran. As well as arrays this function
194 also handles strings as they can be treated like arrays of characters.
195 ARRAY is the array or string being accessed. EXP, POS, and NOSIDE are
196 as for evaluate_subexp_standard, and NARGS is the number of arguments
197 in this access (e.g. 'array (1,2,3)' would be NARGS 3). */
199 static struct value
*
200 fortran_value_subarray (struct value
*array
, struct expression
*exp
,
201 int *pos
, int nargs
, enum noside noside
)
203 if (exp
->elts
[*pos
].opcode
== OP_RANGE
)
204 return value_f90_subarray (array
, exp
, pos
, noside
);
206 if (noside
== EVAL_SKIP
)
208 skip_undetermined_arglist (nargs
, exp
, pos
, noside
);
209 /* Return the dummy value with the correct type. */
213 LONGEST subscript_array
[MAX_FORTRAN_DIMS
];
215 struct type
*type
= check_typedef (value_type (array
));
217 if (nargs
> MAX_FORTRAN_DIMS
)
218 error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS
);
220 ndimensions
= calc_f77_array_dims (type
);
222 if (nargs
!= ndimensions
)
223 error (_("Wrong number of subscripts"));
225 gdb_assert (nargs
> 0);
227 /* Now that we know we have a legal array subscript expression let us
228 actually find out where this element exists in the array. */
230 /* Take array indices left to right. */
231 for (int i
= 0; i
< nargs
; i
++)
233 /* Evaluate each subscript; it must be a legal integer in F77. */
234 value
*arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
236 /* Fill in the subscript array. */
237 subscript_array
[i
] = value_as_long (arg2
);
240 /* Internal type of array is arranged right to left. */
241 for (int i
= nargs
; i
> 0; i
--)
243 struct type
*array_type
= check_typedef (value_type (array
));
244 LONGEST index
= subscript_array
[i
- 1];
246 array
= value_subscripted_rvalue (array
, index
,
247 f77_get_lowerbound (array_type
));
253 /* Special expression evaluation cases for Fortran. */
255 static struct value
*
256 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
257 int *pos
, enum noside noside
)
259 struct value
*arg1
= NULL
, *arg2
= NULL
;
266 op
= exp
->elts
[pc
].opcode
;
272 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
275 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
276 if (noside
== EVAL_SKIP
)
277 return eval_skip_value (exp
);
278 type
= value_type (arg1
);
279 switch (type
->code ())
284 = fabs (target_float_to_host_double (value_contents (arg1
),
286 return value_from_host_double (type
, d
);
290 LONGEST l
= value_as_long (arg1
);
292 return value_from_longest (type
, l
);
295 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
298 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
299 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
300 if (noside
== EVAL_SKIP
)
301 return eval_skip_value (exp
);
302 type
= value_type (arg1
);
303 if (type
->code () != value_type (arg2
)->code ())
304 error (_("non-matching types for parameters to MOD ()"));
305 switch (type
->code ())
310 = target_float_to_host_double (value_contents (arg1
),
313 = target_float_to_host_double (value_contents (arg2
),
315 double d3
= fmod (d1
, d2
);
316 return value_from_host_double (type
, d3
);
320 LONGEST v1
= value_as_long (arg1
);
321 LONGEST v2
= value_as_long (arg2
);
323 error (_("calling MOD (N, 0) is undefined"));
324 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
325 return value_from_longest (value_type (arg1
), v3
);
328 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
330 case UNOP_FORTRAN_CEILING
:
332 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
333 if (noside
== EVAL_SKIP
)
334 return eval_skip_value (exp
);
335 type
= value_type (arg1
);
336 if (type
->code () != TYPE_CODE_FLT
)
337 error (_("argument to CEILING must be of type float"));
339 = target_float_to_host_double (value_contents (arg1
),
342 return value_from_host_double (type
, val
);
345 case UNOP_FORTRAN_FLOOR
:
347 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
348 if (noside
== EVAL_SKIP
)
349 return eval_skip_value (exp
);
350 type
= value_type (arg1
);
351 if (type
->code () != TYPE_CODE_FLT
)
352 error (_("argument to FLOOR must be of type float"));
354 = target_float_to_host_double (value_contents (arg1
),
357 return value_from_host_double (type
, val
);
360 case BINOP_FORTRAN_MODULO
:
362 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
363 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
364 if (noside
== EVAL_SKIP
)
365 return eval_skip_value (exp
);
366 type
= value_type (arg1
);
367 if (type
->code () != value_type (arg2
)->code ())
368 error (_("non-matching types for parameters to MODULO ()"));
369 /* MODULO(A, P) = A - FLOOR (A / P) * P */
370 switch (type
->code ())
374 LONGEST a
= value_as_long (arg1
);
375 LONGEST p
= value_as_long (arg2
);
376 LONGEST result
= a
- (a
/ p
) * p
;
377 if (result
!= 0 && (a
< 0) != (p
< 0))
379 return value_from_longest (value_type (arg1
), result
);
384 = target_float_to_host_double (value_contents (arg1
),
387 = target_float_to_host_double (value_contents (arg2
),
389 double result
= fmod (a
, p
);
390 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
392 return value_from_host_double (type
, result
);
395 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
398 case BINOP_FORTRAN_CMPLX
:
399 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
400 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
401 if (noside
== EVAL_SKIP
)
402 return eval_skip_value (exp
);
403 type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
404 return value_literal_complex (arg1
, arg2
, type
);
406 case UNOP_FORTRAN_KIND
:
407 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
408 type
= value_type (arg1
);
410 switch (type
->code ())
412 case TYPE_CODE_STRUCT
:
413 case TYPE_CODE_UNION
:
414 case TYPE_CODE_MODULE
:
416 error (_("argument to kind must be an intrinsic type"));
419 if (!TYPE_TARGET_TYPE (type
))
420 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
422 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
423 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
426 case OP_F77_UNDETERMINED_ARGLIST
:
427 /* Remember that in F77, functions, substring ops and array subscript
428 operations cannot be disambiguated at parse time. We have made
429 all array subscript operations, substring operations as well as
430 function calls come here and we now have to discover what the heck
431 this thing actually was. If it is a function, we process just as
432 if we got an OP_FUNCALL. */
433 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
436 /* First determine the type code we are dealing with. */
437 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
438 type
= check_typedef (value_type (arg1
));
439 enum type_code code
= type
->code ();
441 if (code
== TYPE_CODE_PTR
)
443 /* Fortran always passes variable to subroutines as pointer.
444 So we need to look into its target type to see if it is
445 array, string or function. If it is, we need to switch
446 to the target value the original one points to. */
447 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
449 if (target_type
->code () == TYPE_CODE_ARRAY
450 || target_type
->code () == TYPE_CODE_STRING
451 || target_type
->code () == TYPE_CODE_FUNC
)
453 arg1
= value_ind (arg1
);
454 type
= check_typedef (value_type (arg1
));
455 code
= type
->code ();
461 case TYPE_CODE_ARRAY
:
462 case TYPE_CODE_STRING
:
463 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
467 case TYPE_CODE_INTERNAL_FUNCTION
:
469 /* It's a function call. Allocate arg vector, including
470 space for the function to be called in argvec[0] and a
472 struct value
**argvec
= (struct value
**)
473 alloca (sizeof (struct value
*) * (nargs
+ 2));
476 for (; tem
<= nargs
; tem
++)
478 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
479 /* Arguments in Fortran are passed by address. Coerce the
480 arguments here rather than in value_arg_coerce as
481 otherwise the call to malloc to place the non-lvalue
482 parameters in target memory is hit by this Fortran
483 specific logic. This results in malloc being called
484 with a pointer to an integer followed by an attempt to
485 malloc the arguments to malloc in target memory.
486 Infinite recursion ensues. */
487 if (code
== TYPE_CODE_PTR
|| code
== TYPE_CODE_FUNC
)
490 = TYPE_FIELD_ARTIFICIAL (value_type (arg1
), tem
- 1);
491 argvec
[tem
] = fortran_argument_convert (argvec
[tem
],
495 argvec
[tem
] = 0; /* signal end of arglist */
496 if (noside
== EVAL_SKIP
)
497 return eval_skip_value (exp
);
498 return evaluate_subexp_do_call (exp
, noside
, nargs
, argvec
, NULL
,
503 error (_("Cannot perform substring on this type"));
507 /* Should be unreachable. */
511 /* Special expression lengths for Fortran. */
514 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
520 switch (exp
->elts
[pc
- 1].opcode
)
523 operator_length_standard (exp
, pc
, oplenp
, argsp
);
526 case UNOP_FORTRAN_KIND
:
527 case UNOP_FORTRAN_FLOOR
:
528 case UNOP_FORTRAN_CEILING
:
533 case BINOP_FORTRAN_CMPLX
:
534 case BINOP_FORTRAN_MODULO
:
539 case OP_F77_UNDETERMINED_ARGLIST
:
541 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
549 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
550 the extra argument NAME which is the text that should be printed as the
551 name of this operation. */
554 print_unop_subexp_f (struct expression
*exp
, int *pos
,
555 struct ui_file
*stream
, enum precedence prec
,
559 fprintf_filtered (stream
, "%s(", name
);
560 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
561 fputs_filtered (")", stream
);
564 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
565 the extra argument NAME which is the text that should be printed as the
566 name of this operation. */
569 print_binop_subexp_f (struct expression
*exp
, int *pos
,
570 struct ui_file
*stream
, enum precedence prec
,
574 fprintf_filtered (stream
, "%s(", name
);
575 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
576 fputs_filtered (",", stream
);
577 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
578 fputs_filtered (")", stream
);
581 /* Special expression printing for Fortran. */
584 print_subexp_f (struct expression
*exp
, int *pos
,
585 struct ui_file
*stream
, enum precedence prec
)
588 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
593 print_subexp_standard (exp
, pos
, stream
, prec
);
596 case UNOP_FORTRAN_KIND
:
597 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
600 case UNOP_FORTRAN_FLOOR
:
601 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
604 case UNOP_FORTRAN_CEILING
:
605 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
608 case BINOP_FORTRAN_CMPLX
:
609 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
612 case BINOP_FORTRAN_MODULO
:
613 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
616 case OP_F77_UNDETERMINED_ARGLIST
:
618 print_subexp_funcall (exp
, pos
, stream
);
623 /* Special expression names for Fortran. */
626 op_name_f (enum exp_opcode opcode
)
631 return op_name_standard (opcode
);
636 #include "fortran-operator.def"
641 /* Special expression dumping for Fortran. */
644 dump_subexp_body_f (struct expression
*exp
,
645 struct ui_file
*stream
, int elt
)
647 int opcode
= exp
->elts
[elt
].opcode
;
653 return dump_subexp_body_standard (exp
, stream
, elt
);
655 case UNOP_FORTRAN_KIND
:
656 case UNOP_FORTRAN_FLOOR
:
657 case UNOP_FORTRAN_CEILING
:
658 case BINOP_FORTRAN_CMPLX
:
659 case BINOP_FORTRAN_MODULO
:
660 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
663 case OP_F77_UNDETERMINED_ARGLIST
:
664 return dump_subexp_body_funcall (exp
, stream
, elt
+ 1);
668 for (i
= 0; i
< nargs
; i
+= 1)
669 elt
= dump_subexp (exp
, stream
, elt
);
674 /* Special expression checking for Fortran. */
677 operator_check_f (struct expression
*exp
, int pos
,
678 int (*objfile_func
) (struct objfile
*objfile
,
682 const union exp_element
*const elts
= exp
->elts
;
684 switch (elts
[pos
].opcode
)
686 case UNOP_FORTRAN_KIND
:
687 case UNOP_FORTRAN_FLOOR
:
688 case UNOP_FORTRAN_CEILING
:
689 case BINOP_FORTRAN_CMPLX
:
690 case BINOP_FORTRAN_MODULO
:
691 /* Any references to objfiles are held in the arguments to this
692 expression, not within the expression itself, so no additional
693 checking is required here, the outer expression iteration code
694 will take care of checking each argument. */
698 return operator_check_standard (exp
, pos
, objfile_func
, data
);
704 /* Expression processing for Fortran. */
705 const struct exp_descriptor
f_language::exp_descriptor_tab
=
715 /* See language.h. */
718 f_language::language_arch_info (struct gdbarch
*gdbarch
,
719 struct language_arch_info
*lai
) const
721 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
723 lai
->string_char_type
= builtin
->builtin_character
;
724 lai
->primitive_type_vector
725 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_f_primitive_types
+ 1,
728 lai
->primitive_type_vector
[f_primitive_type_character
]
729 = builtin
->builtin_character
;
730 lai
->primitive_type_vector
[f_primitive_type_logical
]
731 = builtin
->builtin_logical
;
732 lai
->primitive_type_vector
[f_primitive_type_logical_s1
]
733 = builtin
->builtin_logical_s1
;
734 lai
->primitive_type_vector
[f_primitive_type_logical_s2
]
735 = builtin
->builtin_logical_s2
;
736 lai
->primitive_type_vector
[f_primitive_type_logical_s8
]
737 = builtin
->builtin_logical_s8
;
738 lai
->primitive_type_vector
[f_primitive_type_real
]
739 = builtin
->builtin_real
;
740 lai
->primitive_type_vector
[f_primitive_type_real_s8
]
741 = builtin
->builtin_real_s8
;
742 lai
->primitive_type_vector
[f_primitive_type_real_s16
]
743 = builtin
->builtin_real_s16
;
744 lai
->primitive_type_vector
[f_primitive_type_complex_s8
]
745 = builtin
->builtin_complex_s8
;
746 lai
->primitive_type_vector
[f_primitive_type_complex_s16
]
747 = builtin
->builtin_complex_s16
;
748 lai
->primitive_type_vector
[f_primitive_type_void
]
749 = builtin
->builtin_void
;
751 lai
->bool_type_symbol
= "logical";
752 lai
->bool_type_default
= builtin
->builtin_logical_s2
;
755 /* See language.h. */
758 f_language::search_name_hash (const char *name
) const
760 return cp_search_name_hash (name
);
763 /* See language.h. */
766 f_language::lookup_symbol_nonlocal (const char *name
,
767 const struct block
*block
,
768 const domain_enum domain
) const
770 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
773 /* See language.h. */
775 symbol_name_matcher_ftype
*
776 f_language::get_symbol_name_matcher_inner
777 (const lookup_name_info
&lookup_name
) const
779 return cp_get_symbol_name_matcher (lookup_name
);
782 /* Single instance of the Fortran language class. */
784 static f_language f_language_defn
;
787 build_fortran_types (struct gdbarch
*gdbarch
)
789 struct builtin_f_type
*builtin_f_type
790 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
792 builtin_f_type
->builtin_void
793 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
795 builtin_f_type
->builtin_character
796 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
798 builtin_f_type
->builtin_logical_s1
799 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
801 builtin_f_type
->builtin_integer_s2
802 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
805 builtin_f_type
->builtin_integer_s8
806 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
809 builtin_f_type
->builtin_logical_s2
810 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
813 builtin_f_type
->builtin_logical_s8
814 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
817 builtin_f_type
->builtin_integer
818 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
821 builtin_f_type
->builtin_logical
822 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
825 builtin_f_type
->builtin_real
826 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
827 "real", gdbarch_float_format (gdbarch
));
828 builtin_f_type
->builtin_real_s8
829 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
830 "real*8", gdbarch_double_format (gdbarch
));
831 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
833 builtin_f_type
->builtin_real_s16
834 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
835 else if (gdbarch_long_double_bit (gdbarch
) == 128)
836 builtin_f_type
->builtin_real_s16
837 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
838 "real*16", gdbarch_long_double_format (gdbarch
));
840 builtin_f_type
->builtin_real_s16
841 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
843 builtin_f_type
->builtin_complex_s8
844 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
845 builtin_f_type
->builtin_complex_s16
846 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
848 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
849 builtin_f_type
->builtin_complex_s32
850 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
852 builtin_f_type
->builtin_complex_s32
853 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
855 return builtin_f_type
;
858 static struct gdbarch_data
*f_type_data
;
860 const struct builtin_f_type
*
861 builtin_f_type (struct gdbarch
*gdbarch
)
863 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
866 void _initialize_f_language ();
868 _initialize_f_language ()
870 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
876 fortran_argument_convert (struct value
*value
, bool is_artificial
)
880 /* If the value is not in the inferior e.g. registers values,
881 convenience variables and user input. */
882 if (VALUE_LVAL (value
) != lval_memory
)
884 struct type
*type
= value_type (value
);
885 const int length
= TYPE_LENGTH (type
);
887 = value_as_long (value_allocate_space_in_inferior (length
));
888 write_memory (addr
, value_contents (value
), length
);
890 = value_from_contents_and_address (type
, value_contents (value
),
892 return value_addr (val
);
895 return value_addr (value
); /* Program variables, e.g. arrays. */
903 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
905 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
906 return value_type (arg
);