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_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 static const struct op_print f_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
;
128 struct type
*range
= check_typedef (value_type (array
)->index_type ());
129 enum range_type range_type
130 = (enum range_type
) longest_to_int (exp
->elts
[pc
].longconst
);
134 if (range_type
== LOW_BOUND_DEFAULT
|| range_type
== BOTH_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_type
== HIGH_BOUND_DEFAULT
|| range_type
== BOTH_BOUND_DEFAULT
)
140 high_bound
= range
->bounds ()->high
.const_val ();
142 high_bound
= value_as_long (evaluate_subexp (nullptr, exp
, pos
, noside
));
144 return value_slice (array
, low_bound
, high_bound
- low_bound
+ 1);
147 /* Helper for skipping all the arguments in an undetermined argument list.
148 This function was designed for use in the OP_F77_UNDETERMINED_ARGLIST
149 case of evaluate_subexp_standard as multiple, but not all, code paths
150 require a generic skip. */
153 skip_undetermined_arglist (int nargs
, struct expression
*exp
, int *pos
,
156 for (int i
= 0; i
< nargs
; ++i
)
157 evaluate_subexp (nullptr, exp
, pos
, noside
);
160 /* Return the number of dimensions for a Fortran array or string. */
163 calc_f77_array_dims (struct type
*array_type
)
166 struct type
*tmp_type
;
168 if ((array_type
->code () == TYPE_CODE_STRING
))
171 if ((array_type
->code () != TYPE_CODE_ARRAY
))
172 error (_("Can't get dimensions for a non-array type"));
174 tmp_type
= array_type
;
176 while ((tmp_type
= TYPE_TARGET_TYPE (tmp_type
)))
178 if (tmp_type
->code () == TYPE_CODE_ARRAY
)
184 /* Called from evaluate_subexp_standard to perform array indexing, and
185 sub-range extraction, for Fortran. As well as arrays this function
186 also handles strings as they can be treated like arrays of characters.
187 ARRAY is the array or string being accessed. EXP, POS, and NOSIDE are
188 as for evaluate_subexp_standard, and NARGS is the number of arguments
189 in this access (e.g. 'array (1,2,3)' would be NARGS 3). */
191 static struct value
*
192 fortran_value_subarray (struct value
*array
, struct expression
*exp
,
193 int *pos
, int nargs
, enum noside noside
)
195 if (exp
->elts
[*pos
].opcode
== OP_RANGE
)
196 return value_f90_subarray (array
, exp
, pos
, noside
);
198 if (noside
== EVAL_SKIP
)
200 skip_undetermined_arglist (nargs
, exp
, pos
, noside
);
201 /* Return the dummy value with the correct type. */
205 LONGEST subscript_array
[MAX_FORTRAN_DIMS
];
207 struct type
*type
= check_typedef (value_type (array
));
209 if (nargs
> MAX_FORTRAN_DIMS
)
210 error (_("Too many subscripts for F77 (%d Max)"), MAX_FORTRAN_DIMS
);
212 ndimensions
= calc_f77_array_dims (type
);
214 if (nargs
!= ndimensions
)
215 error (_("Wrong number of subscripts"));
217 gdb_assert (nargs
> 0);
219 /* Now that we know we have a legal array subscript expression let us
220 actually find out where this element exists in the array. */
222 /* Take array indices left to right. */
223 for (int i
= 0; i
< nargs
; i
++)
225 /* Evaluate each subscript; it must be a legal integer in F77. */
226 value
*arg2
= evaluate_subexp_with_coercion (exp
, pos
, noside
);
228 /* Fill in the subscript array. */
229 subscript_array
[i
] = value_as_long (arg2
);
232 /* Internal type of array is arranged right to left. */
233 for (int i
= nargs
; i
> 0; i
--)
235 struct type
*array_type
= check_typedef (value_type (array
));
236 LONGEST index
= subscript_array
[i
- 1];
238 array
= value_subscripted_rvalue (array
, index
,
239 f77_get_lowerbound (array_type
));
245 /* Special expression evaluation cases for Fortran. */
247 static struct value
*
248 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
249 int *pos
, enum noside noside
)
251 struct value
*arg1
= NULL
, *arg2
= NULL
;
258 op
= exp
->elts
[pc
].opcode
;
264 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
267 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
268 if (noside
== EVAL_SKIP
)
269 return eval_skip_value (exp
);
270 type
= value_type (arg1
);
271 switch (type
->code ())
276 = fabs (target_float_to_host_double (value_contents (arg1
),
278 return value_from_host_double (type
, d
);
282 LONGEST l
= value_as_long (arg1
);
284 return value_from_longest (type
, l
);
287 error (_("ABS of type %s not supported"), TYPE_SAFE_NAME (type
));
290 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
291 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
292 if (noside
== EVAL_SKIP
)
293 return eval_skip_value (exp
);
294 type
= value_type (arg1
);
295 if (type
->code () != value_type (arg2
)->code ())
296 error (_("non-matching types for parameters to MOD ()"));
297 switch (type
->code ())
302 = target_float_to_host_double (value_contents (arg1
),
305 = target_float_to_host_double (value_contents (arg2
),
307 double d3
= fmod (d1
, d2
);
308 return value_from_host_double (type
, d3
);
312 LONGEST v1
= value_as_long (arg1
);
313 LONGEST v2
= value_as_long (arg2
);
315 error (_("calling MOD (N, 0) is undefined"));
316 LONGEST v3
= v1
- (v1
/ v2
) * v2
;
317 return value_from_longest (value_type (arg1
), v3
);
320 error (_("MOD of type %s not supported"), TYPE_SAFE_NAME (type
));
322 case UNOP_FORTRAN_CEILING
:
324 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
325 if (noside
== EVAL_SKIP
)
326 return eval_skip_value (exp
);
327 type
= value_type (arg1
);
328 if (type
->code () != TYPE_CODE_FLT
)
329 error (_("argument to CEILING must be of type float"));
331 = target_float_to_host_double (value_contents (arg1
),
334 return value_from_host_double (type
, val
);
337 case UNOP_FORTRAN_FLOOR
:
339 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
340 if (noside
== EVAL_SKIP
)
341 return eval_skip_value (exp
);
342 type
= value_type (arg1
);
343 if (type
->code () != TYPE_CODE_FLT
)
344 error (_("argument to FLOOR must be of type float"));
346 = target_float_to_host_double (value_contents (arg1
),
349 return value_from_host_double (type
, val
);
352 case BINOP_FORTRAN_MODULO
:
354 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
355 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
356 if (noside
== EVAL_SKIP
)
357 return eval_skip_value (exp
);
358 type
= value_type (arg1
);
359 if (type
->code () != value_type (arg2
)->code ())
360 error (_("non-matching types for parameters to MODULO ()"));
361 /* MODULO(A, P) = A - FLOOR (A / P) * P */
362 switch (type
->code ())
366 LONGEST a
= value_as_long (arg1
);
367 LONGEST p
= value_as_long (arg2
);
368 LONGEST result
= a
- (a
/ p
) * p
;
369 if (result
!= 0 && (a
< 0) != (p
< 0))
371 return value_from_longest (value_type (arg1
), result
);
376 = target_float_to_host_double (value_contents (arg1
),
379 = target_float_to_host_double (value_contents (arg2
),
381 double result
= fmod (a
, p
);
382 if (result
!= 0 && (a
< 0.0) != (p
< 0.0))
384 return value_from_host_double (type
, result
);
387 error (_("MODULO of type %s not supported"), TYPE_SAFE_NAME (type
));
390 case BINOP_FORTRAN_CMPLX
:
391 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
392 arg2
= evaluate_subexp (value_type (arg1
), exp
, pos
, noside
);
393 if (noside
== EVAL_SKIP
)
394 return eval_skip_value (exp
);
395 type
= builtin_f_type(exp
->gdbarch
)->builtin_complex_s16
;
396 return value_literal_complex (arg1
, arg2
, type
);
398 case UNOP_FORTRAN_KIND
:
399 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
400 type
= value_type (arg1
);
402 switch (type
->code ())
404 case TYPE_CODE_STRUCT
:
405 case TYPE_CODE_UNION
:
406 case TYPE_CODE_MODULE
:
408 error (_("argument to kind must be an intrinsic type"));
411 if (!TYPE_TARGET_TYPE (type
))
412 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
414 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
415 TYPE_LENGTH (TYPE_TARGET_TYPE (type
)));
418 case OP_F77_UNDETERMINED_ARGLIST
:
419 /* Remember that in F77, functions, substring ops and array subscript
420 operations cannot be disambiguated at parse time. We have made
421 all array subscript operations, substring operations as well as
422 function calls come here and we now have to discover what the heck
423 this thing actually was. If it is a function, we process just as
424 if we got an OP_FUNCALL. */
425 int nargs
= longest_to_int (exp
->elts
[pc
+ 1].longconst
);
428 /* First determine the type code we are dealing with. */
429 arg1
= evaluate_subexp (nullptr, exp
, pos
, noside
);
430 type
= check_typedef (value_type (arg1
));
431 enum type_code code
= type
->code ();
433 if (code
== TYPE_CODE_PTR
)
435 /* Fortran always passes variable to subroutines as pointer.
436 So we need to look into its target type to see if it is
437 array, string or function. If it is, we need to switch
438 to the target value the original one points to. */
439 struct type
*target_type
= check_typedef (TYPE_TARGET_TYPE (type
));
441 if (target_type
->code () == TYPE_CODE_ARRAY
442 || target_type
->code () == TYPE_CODE_STRING
443 || target_type
->code () == TYPE_CODE_FUNC
)
445 arg1
= value_ind (arg1
);
446 type
= check_typedef (value_type (arg1
));
447 code
= type
->code ();
453 case TYPE_CODE_ARRAY
:
454 case TYPE_CODE_STRING
:
455 return fortran_value_subarray (arg1
, exp
, pos
, nargs
, noside
);
459 case TYPE_CODE_INTERNAL_FUNCTION
:
461 /* It's a function call. Allocate arg vector, including
462 space for the function to be called in argvec[0] and a
464 struct value
**argvec
= (struct value
**)
465 alloca (sizeof (struct value
*) * (nargs
+ 2));
468 for (; tem
<= nargs
; tem
++)
470 argvec
[tem
] = evaluate_subexp_with_coercion (exp
, pos
, noside
);
471 /* Arguments in Fortran are passed by address. Coerce the
472 arguments here rather than in value_arg_coerce as
473 otherwise the call to malloc to place the non-lvalue
474 parameters in target memory is hit by this Fortran
475 specific logic. This results in malloc being called
476 with a pointer to an integer followed by an attempt to
477 malloc the arguments to malloc in target memory.
478 Infinite recursion ensues. */
479 if (code
== TYPE_CODE_PTR
|| code
== TYPE_CODE_FUNC
)
482 = TYPE_FIELD_ARTIFICIAL (value_type (arg1
), tem
- 1);
483 argvec
[tem
] = fortran_argument_convert (argvec
[tem
],
487 argvec
[tem
] = 0; /* signal end of arglist */
488 if (noside
== EVAL_SKIP
)
489 return eval_skip_value (exp
);
490 return evaluate_subexp_do_call (exp
, noside
, nargs
, argvec
, NULL
,
495 error (_("Cannot perform substring on this type"));
499 /* Should be unreachable. */
503 /* Special expression lengths for Fortran. */
506 operator_length_f (const struct expression
*exp
, int pc
, int *oplenp
,
512 switch (exp
->elts
[pc
- 1].opcode
)
515 operator_length_standard (exp
, pc
, oplenp
, argsp
);
518 case UNOP_FORTRAN_KIND
:
519 case UNOP_FORTRAN_FLOOR
:
520 case UNOP_FORTRAN_CEILING
:
525 case BINOP_FORTRAN_CMPLX
:
526 case BINOP_FORTRAN_MODULO
:
531 case OP_F77_UNDETERMINED_ARGLIST
:
533 args
= 1 + longest_to_int (exp
->elts
[pc
- 2].longconst
);
541 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
542 the extra argument NAME which is the text that should be printed as the
543 name of this operation. */
546 print_unop_subexp_f (struct expression
*exp
, int *pos
,
547 struct ui_file
*stream
, enum precedence prec
,
551 fprintf_filtered (stream
, "%s(", name
);
552 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
553 fputs_filtered (")", stream
);
556 /* Helper for PRINT_SUBEXP_F. Arguments are as for PRINT_SUBEXP_F, except
557 the extra argument NAME which is the text that should be printed as the
558 name of this operation. */
561 print_binop_subexp_f (struct expression
*exp
, int *pos
,
562 struct ui_file
*stream
, enum precedence prec
,
566 fprintf_filtered (stream
, "%s(", name
);
567 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
568 fputs_filtered (",", stream
);
569 print_subexp (exp
, pos
, stream
, PREC_SUFFIX
);
570 fputs_filtered (")", stream
);
573 /* Special expression printing for Fortran. */
576 print_subexp_f (struct expression
*exp
, int *pos
,
577 struct ui_file
*stream
, enum precedence prec
)
580 enum exp_opcode op
= exp
->elts
[pc
].opcode
;
585 print_subexp_standard (exp
, pos
, stream
, prec
);
588 case UNOP_FORTRAN_KIND
:
589 print_unop_subexp_f (exp
, pos
, stream
, prec
, "KIND");
592 case UNOP_FORTRAN_FLOOR
:
593 print_unop_subexp_f (exp
, pos
, stream
, prec
, "FLOOR");
596 case UNOP_FORTRAN_CEILING
:
597 print_unop_subexp_f (exp
, pos
, stream
, prec
, "CEILING");
600 case BINOP_FORTRAN_CMPLX
:
601 print_binop_subexp_f (exp
, pos
, stream
, prec
, "CMPLX");
604 case BINOP_FORTRAN_MODULO
:
605 print_binop_subexp_f (exp
, pos
, stream
, prec
, "MODULO");
608 case OP_F77_UNDETERMINED_ARGLIST
:
609 print_subexp_funcall (exp
, pos
, stream
);
614 /* Special expression names for Fortran. */
617 op_name_f (enum exp_opcode opcode
)
622 return op_name_standard (opcode
);
627 #include "fortran-operator.def"
632 /* Special expression dumping for Fortran. */
635 dump_subexp_body_f (struct expression
*exp
,
636 struct ui_file
*stream
, int elt
)
638 int opcode
= exp
->elts
[elt
].opcode
;
644 return dump_subexp_body_standard (exp
, stream
, elt
);
646 case UNOP_FORTRAN_KIND
:
647 case UNOP_FORTRAN_FLOOR
:
648 case UNOP_FORTRAN_CEILING
:
649 case BINOP_FORTRAN_CMPLX
:
650 case BINOP_FORTRAN_MODULO
:
651 operator_length_f (exp
, (elt
+ 1), &oplen
, &nargs
);
654 case OP_F77_UNDETERMINED_ARGLIST
:
655 return dump_subexp_body_funcall (exp
, stream
, elt
);
659 for (i
= 0; i
< nargs
; i
+= 1)
660 elt
= dump_subexp (exp
, stream
, elt
);
665 /* Special expression checking for Fortran. */
668 operator_check_f (struct expression
*exp
, int pos
,
669 int (*objfile_func
) (struct objfile
*objfile
,
673 const union exp_element
*const elts
= exp
->elts
;
675 switch (elts
[pos
].opcode
)
677 case UNOP_FORTRAN_KIND
:
678 case UNOP_FORTRAN_FLOOR
:
679 case UNOP_FORTRAN_CEILING
:
680 case BINOP_FORTRAN_CMPLX
:
681 case BINOP_FORTRAN_MODULO
:
682 /* Any references to objfiles are held in the arguments to this
683 expression, not within the expression itself, so no additional
684 checking is required here, the outer expression iteration code
685 will take care of checking each argument. */
689 return operator_check_standard (exp
, pos
, objfile_func
, data
);
695 /* Expression processing for Fortran. */
696 static const struct exp_descriptor exp_descriptor_f
=
706 /* Class representing the Fortran language. */
708 class f_language
: public language_defn
712 : language_defn (language_fortran
)
715 /* See language.h. */
717 const char *name () const override
718 { return "fortran"; }
720 /* See language.h. */
722 const char *natural_name () const override
723 { return "Fortran"; }
725 /* See language.h. */
727 const std::vector
<const char *> &filename_extensions () const override
729 static const std::vector
<const char *> extensions
= {
730 ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
731 ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08"
736 /* See language.h. */
737 void language_arch_info (struct gdbarch
*gdbarch
,
738 struct language_arch_info
*lai
) const override
740 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
742 lai
->string_char_type
= builtin
->builtin_character
;
743 lai
->primitive_type_vector
744 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_f_primitive_types
+ 1,
747 lai
->primitive_type_vector
[f_primitive_type_character
]
748 = builtin
->builtin_character
;
749 lai
->primitive_type_vector
[f_primitive_type_logical
]
750 = builtin
->builtin_logical
;
751 lai
->primitive_type_vector
[f_primitive_type_logical_s1
]
752 = builtin
->builtin_logical_s1
;
753 lai
->primitive_type_vector
[f_primitive_type_logical_s2
]
754 = builtin
->builtin_logical_s2
;
755 lai
->primitive_type_vector
[f_primitive_type_logical_s8
]
756 = builtin
->builtin_logical_s8
;
757 lai
->primitive_type_vector
[f_primitive_type_real
]
758 = builtin
->builtin_real
;
759 lai
->primitive_type_vector
[f_primitive_type_real_s8
]
760 = builtin
->builtin_real_s8
;
761 lai
->primitive_type_vector
[f_primitive_type_real_s16
]
762 = builtin
->builtin_real_s16
;
763 lai
->primitive_type_vector
[f_primitive_type_complex_s8
]
764 = builtin
->builtin_complex_s8
;
765 lai
->primitive_type_vector
[f_primitive_type_complex_s16
]
766 = builtin
->builtin_complex_s16
;
767 lai
->primitive_type_vector
[f_primitive_type_void
]
768 = builtin
->builtin_void
;
770 lai
->bool_type_symbol
= "logical";
771 lai
->bool_type_default
= builtin
->builtin_logical_s2
;
774 /* See language.h. */
775 unsigned int search_name_hash (const char *name
) const override
777 return cp_search_name_hash (name
);
780 /* See language.h. */
782 char *demangle (const char *mangled
, int options
) const override
784 /* We could support demangling here to provide module namespaces
785 also for inferiors with only minimal symbol table (ELF symbols).
786 Just the mangling standard is not standardized across compilers
787 and there is no DW_AT_producer available for inferiors with only
788 the ELF symbols to check the mangling kind. */
792 /* See language.h. */
794 void print_type (struct type
*type
, const char *varstring
,
795 struct ui_file
*stream
, int show
, int level
,
796 const struct type_print_options
*flags
) const override
798 f_print_type (type
, varstring
, stream
, show
, level
, flags
);
801 /* See language.h. This just returns default set of word break
802 characters but with the modules separator `::' removed. */
804 const char *word_break_characters (void) const override
812 retval
= xstrdup (language_defn::word_break_characters ());
813 s
= strchr (retval
, ':');
816 char *last_char
= &s
[strlen (s
) - 1];
826 /* See language.h. */
828 void collect_symbol_completion_matches (completion_tracker
&tracker
,
829 complete_symbol_mode mode
,
830 symbol_name_match_type name_match_type
,
831 const char *text
, const char *word
,
832 enum type_code code
) const override
834 /* Consider the modules separator :: as a valid symbol name character
836 default_collect_symbol_completion_matches_break_on (tracker
, mode
,
842 /* See language.h. */
844 void value_print_inner
845 (struct value
*val
, struct ui_file
*stream
, int recurse
,
846 const struct value_print_options
*options
) const override
848 return f_value_print_inner (val
, stream
, recurse
, options
);
851 /* See language.h. */
853 struct block_symbol lookup_symbol_nonlocal
854 (const char *name
, const struct block
*block
,
855 const domain_enum domain
) const override
857 return cp_lookup_symbol_nonlocal (this, name
, block
, domain
);
860 /* See language.h. */
862 int parser (struct parser_state
*ps
) const override
867 /* See language.h. */
869 void emitchar (int ch
, struct type
*chtype
,
870 struct ui_file
*stream
, int quoter
) const override
872 const char *encoding
= f_get_encoding (chtype
);
873 generic_emit_char (ch
, chtype
, stream
, quoter
, encoding
);
876 /* See language.h. */
878 void printchar (int ch
, struct type
*chtype
,
879 struct ui_file
*stream
) const override
881 fputs_filtered ("'", stream
);
882 LA_EMIT_CHAR (ch
, chtype
, stream
, '\'');
883 fputs_filtered ("'", stream
);
886 /* See language.h. */
888 void printstr (struct ui_file
*stream
, struct type
*elttype
,
889 const gdb_byte
*string
, unsigned int length
,
890 const char *encoding
, int force_ellipses
,
891 const struct value_print_options
*options
) const override
893 const char *type_encoding
= f_get_encoding (elttype
);
895 if (TYPE_LENGTH (elttype
) == 4)
896 fputs_filtered ("4_", stream
);
898 if (!encoding
|| !*encoding
)
899 encoding
= type_encoding
;
901 generic_printstr (stream
, elttype
, string
, length
, encoding
,
902 force_ellipses
, '\'', 0, options
);
905 /* See language.h. */
907 void print_typedef (struct type
*type
, struct symbol
*new_symbol
,
908 struct ui_file
*stream
) const override
910 f_print_typedef (type
, new_symbol
, stream
);
913 /* See language.h. */
915 bool is_string_type_p (struct type
*type
) const override
917 type
= check_typedef (type
);
918 return (type
->code () == TYPE_CODE_STRING
919 || (type
->code () == TYPE_CODE_ARRAY
920 && TYPE_TARGET_TYPE (type
)->code () == TYPE_CODE_CHAR
));
923 /* See language.h. */
925 const char *struct_too_deep_ellipsis () const override
928 /* See language.h. */
930 bool c_style_arrays_p () const override
933 /* See language.h. */
935 bool range_checking_on_by_default () const override
938 /* See language.h. */
940 enum case_sensitivity
case_sensitivity () const override
941 { return case_sensitive_off
; }
943 /* See language.h. */
945 enum array_ordering
array_ordering () const override
946 { return array_column_major
; }
948 /* See language.h. */
950 const struct exp_descriptor
*expression_ops () const override
951 { return &exp_descriptor_f
; }
953 /* See language.h. */
955 const struct op_print
*opcode_print_table () const override
956 { return f_op_print_tab
; }
960 /* See language.h. */
962 symbol_name_matcher_ftype
*get_symbol_name_matcher_inner
963 (const lookup_name_info
&lookup_name
) const override
965 return cp_get_symbol_name_matcher (lookup_name
);
969 /* Single instance of the Fortran language class. */
971 static f_language f_language_defn
;
974 build_fortran_types (struct gdbarch
*gdbarch
)
976 struct builtin_f_type
*builtin_f_type
977 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
979 builtin_f_type
->builtin_void
980 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "void");
982 builtin_f_type
->builtin_character
983 = arch_type (gdbarch
, TYPE_CODE_CHAR
, TARGET_CHAR_BIT
, "character");
985 builtin_f_type
->builtin_logical_s1
986 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
988 builtin_f_type
->builtin_integer_s2
989 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
992 builtin_f_type
->builtin_integer_s8
993 = arch_integer_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 0,
996 builtin_f_type
->builtin_logical_s2
997 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
1000 builtin_f_type
->builtin_logical_s8
1001 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
1004 builtin_f_type
->builtin_integer
1005 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
1008 builtin_f_type
->builtin_logical
1009 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
1012 builtin_f_type
->builtin_real
1013 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
1014 "real", gdbarch_float_format (gdbarch
));
1015 builtin_f_type
->builtin_real_s8
1016 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
1017 "real*8", gdbarch_double_format (gdbarch
));
1018 auto fmt
= gdbarch_floatformat_for_type (gdbarch
, "real(kind=16)", 128);
1020 builtin_f_type
->builtin_real_s16
1021 = arch_float_type (gdbarch
, 128, "real*16", fmt
);
1022 else if (gdbarch_long_double_bit (gdbarch
) == 128)
1023 builtin_f_type
->builtin_real_s16
1024 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
1025 "real*16", gdbarch_long_double_format (gdbarch
));
1027 builtin_f_type
->builtin_real_s16
1028 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 128, "real*16");
1030 builtin_f_type
->builtin_complex_s8
1031 = init_complex_type ("complex*8", builtin_f_type
->builtin_real
);
1032 builtin_f_type
->builtin_complex_s16
1033 = init_complex_type ("complex*16", builtin_f_type
->builtin_real_s8
);
1035 if (builtin_f_type
->builtin_real_s16
->code () == TYPE_CODE_ERROR
)
1036 builtin_f_type
->builtin_complex_s32
1037 = arch_type (gdbarch
, TYPE_CODE_ERROR
, 256, "complex*32");
1039 builtin_f_type
->builtin_complex_s32
1040 = init_complex_type ("complex*32", builtin_f_type
->builtin_real_s16
);
1042 return builtin_f_type
;
1045 static struct gdbarch_data
*f_type_data
;
1047 const struct builtin_f_type
*
1048 builtin_f_type (struct gdbarch
*gdbarch
)
1050 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
1053 void _initialize_f_language ();
1055 _initialize_f_language ()
1057 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
1063 fortran_argument_convert (struct value
*value
, bool is_artificial
)
1067 /* If the value is not in the inferior e.g. registers values,
1068 convenience variables and user input. */
1069 if (VALUE_LVAL (value
) != lval_memory
)
1071 struct type
*type
= value_type (value
);
1072 const int length
= TYPE_LENGTH (type
);
1073 const CORE_ADDR addr
1074 = value_as_long (value_allocate_space_in_inferior (length
));
1075 write_memory (addr
, value_contents (value
), length
);
1077 = value_from_contents_and_address (type
, value_contents (value
),
1079 return value_addr (val
);
1082 return value_addr (value
); /* Program variables, e.g. arrays. */
1090 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
1092 if (value_type (arg
)->code () == TYPE_CODE_PTR
)
1093 return value_type (arg
);