1 /* Fortran language support routines for GDB, the GNU debugger.
3 Copyright (C) 1993-2019 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"
41 static void f_printchar (int c
, struct type
*type
, struct ui_file
* stream
);
42 static void f_emit_char (int c
, struct type
*type
,
43 struct ui_file
* stream
, int quoter
);
45 /* Return the encoding that should be used for the character type
49 f_get_encoding (struct type
*type
)
53 switch (TYPE_LENGTH (type
))
56 encoding
= target_charset (get_type_arch (type
));
59 if (gdbarch_byte_order (get_type_arch (type
)) == BFD_ENDIAN_BIG
)
60 encoding
= "UTF-32BE";
62 encoding
= "UTF-32LE";
66 error (_("unrecognized character type"));
72 /* Print the character C on STREAM as part of the contents of a literal
73 string whose delimiter is QUOTER. Note that that format for printing
74 characters and strings is language specific.
75 FIXME: This is a copy of the same function from c-exp.y. It should
76 be replaced with a true F77 version. */
79 f_emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
81 const char *encoding
= f_get_encoding (type
);
83 generic_emit_char (c
, type
, stream
, quoter
, encoding
);
86 /* Implementation of la_printchar. */
89 f_printchar (int c
, struct type
*type
, struct ui_file
*stream
)
91 fputs_filtered ("'", stream
);
92 LA_EMIT_CHAR (c
, type
, stream
, '\'');
93 fputs_filtered ("'", stream
);
96 /* Print the character string STRING, printing at most LENGTH characters.
97 Printing stops early if the number hits print_max; repeat counts
98 are printed as appropriate. Print ellipses at the end if we
99 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
100 FIXME: This is a copy of the same function from c-exp.y. It should
101 be replaced with a true F77 version. */
104 f_printstr (struct ui_file
*stream
, struct type
*type
, const gdb_byte
*string
,
105 unsigned int length
, const char *encoding
, int force_ellipses
,
106 const struct value_print_options
*options
)
108 const char *type_encoding
= f_get_encoding (type
);
110 if (TYPE_LENGTH (type
) == 4)
111 fputs_filtered ("4_", stream
);
113 if (!encoding
|| !*encoding
)
114 encoding
= type_encoding
;
116 generic_printstr (stream
, type
, string
, length
, encoding
,
117 force_ellipses
, '\'', 0, options
);
121 /* Table of operators and their precedences for printing expressions. */
123 static const struct op_print f_op_print_tab
[] =
125 {"+", BINOP_ADD
, PREC_ADD
, 0},
126 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
127 {"-", BINOP_SUB
, PREC_ADD
, 0},
128 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
129 {"*", BINOP_MUL
, PREC_MUL
, 0},
130 {"/", BINOP_DIV
, PREC_MUL
, 0},
131 {"DIV", BINOP_INTDIV
, PREC_MUL
, 0},
132 {"MOD", BINOP_REM
, PREC_MUL
, 0},
133 {"=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
134 {".OR.", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
135 {".AND.", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
136 {".NOT.", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
137 {".EQ.", BINOP_EQUAL
, PREC_EQUAL
, 0},
138 {".NE.", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
139 {".LE.", BINOP_LEQ
, PREC_ORDER
, 0},
140 {".GE.", BINOP_GEQ
, PREC_ORDER
, 0},
141 {".GT.", BINOP_GTR
, PREC_ORDER
, 0},
142 {".LT.", BINOP_LESS
, PREC_ORDER
, 0},
143 {"**", UNOP_IND
, PREC_PREFIX
, 0},
144 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
145 {NULL
, OP_NULL
, PREC_REPEAT
, 0}
148 enum f_primitive_types
{
149 f_primitive_type_character
,
150 f_primitive_type_logical
,
151 f_primitive_type_logical_s1
,
152 f_primitive_type_logical_s2
,
153 f_primitive_type_logical_s8
,
154 f_primitive_type_integer
,
155 f_primitive_type_integer_s2
,
156 f_primitive_type_real
,
157 f_primitive_type_real_s8
,
158 f_primitive_type_real_s16
,
159 f_primitive_type_complex_s8
,
160 f_primitive_type_complex_s16
,
161 f_primitive_type_void
,
166 f_language_arch_info (struct gdbarch
*gdbarch
,
167 struct language_arch_info
*lai
)
169 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
171 lai
->string_char_type
= builtin
->builtin_character
;
172 lai
->primitive_type_vector
173 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_f_primitive_types
+ 1,
176 lai
->primitive_type_vector
[f_primitive_type_character
]
177 = builtin
->builtin_character
;
178 lai
->primitive_type_vector
[f_primitive_type_logical
]
179 = builtin
->builtin_logical
;
180 lai
->primitive_type_vector
[f_primitive_type_logical_s1
]
181 = builtin
->builtin_logical_s1
;
182 lai
->primitive_type_vector
[f_primitive_type_logical_s2
]
183 = builtin
->builtin_logical_s2
;
184 lai
->primitive_type_vector
[f_primitive_type_logical_s8
]
185 = builtin
->builtin_logical_s8
;
186 lai
->primitive_type_vector
[f_primitive_type_real
]
187 = builtin
->builtin_real
;
188 lai
->primitive_type_vector
[f_primitive_type_real_s8
]
189 = builtin
->builtin_real_s8
;
190 lai
->primitive_type_vector
[f_primitive_type_real_s16
]
191 = builtin
->builtin_real_s16
;
192 lai
->primitive_type_vector
[f_primitive_type_complex_s8
]
193 = builtin
->builtin_complex_s8
;
194 lai
->primitive_type_vector
[f_primitive_type_complex_s16
]
195 = builtin
->builtin_complex_s16
;
196 lai
->primitive_type_vector
[f_primitive_type_void
]
197 = builtin
->builtin_void
;
199 lai
->bool_type_symbol
= "logical";
200 lai
->bool_type_default
= builtin
->builtin_logical_s2
;
203 /* Remove the modules separator :: from the default break list. */
206 f_word_break_characters (void)
214 retval
= xstrdup (default_word_break_characters ());
215 s
= strchr (retval
, ':');
218 char *last_char
= &s
[strlen (s
) - 1];
227 /* Consider the modules separator :: as a valid symbol name character
231 f_collect_symbol_completion_matches (completion_tracker
&tracker
,
232 complete_symbol_mode mode
,
233 symbol_name_match_type compare_name
,
234 const char *text
, const char *word
,
237 default_collect_symbol_completion_matches_break_on (tracker
, mode
,
239 text
, word
, ":", code
);
242 /* Special expression evaluation cases for Fortran. */
244 evaluate_subexp_f (struct type
*expect_type
, struct expression
*exp
,
245 int *pos
, enum noside noside
)
247 struct value
*arg1
= NULL
;
254 op
= exp
->elts
[pc
].opcode
;
260 return evaluate_subexp_standard (expect_type
, exp
, pos
, noside
);
263 arg1
= evaluate_subexp (NULL
, exp
, pos
, EVAL_AVOID_SIDE_EFFECTS
);
264 type
= value_type (arg1
);
266 switch (TYPE_CODE (type
))
268 case TYPE_CODE_STRUCT
:
269 case TYPE_CODE_UNION
:
270 case TYPE_CODE_MODULE
:
272 error (_("argument to kind must be an intrinsic type"));
275 if (!TYPE_TARGET_TYPE (type
))
276 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
278 return value_from_longest (builtin_type (exp
->gdbarch
)->builtin_int
,
279 TYPE_LENGTH (TYPE_TARGET_TYPE(type
)));
282 /* Should be unreachable. */
286 static const char *f_extensions
[] =
288 ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
289 ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
293 /* Expression processing for Fortran. */
294 static const struct exp_descriptor exp_descriptor_f
=
296 print_subexp_standard
,
297 operator_length_standard
,
298 operator_check_standard
,
300 dump_subexp_body_standard
,
304 extern const struct language_defn f_language_defn
=
315 f_parse
, /* parser */
317 f_printchar
, /* Print character constant */
318 f_printstr
, /* function to print string constant */
319 f_emit_char
, /* Function to print a single character */
320 f_print_type
, /* Print a type using appropriate syntax */
321 default_print_typedef
, /* Print a typedef using appropriate syntax */
322 f_val_print
, /* Print a value using appropriate syntax */
323 c_value_print
, /* FIXME */
324 default_read_var_value
, /* la_read_var_value */
325 NULL
, /* Language specific skip_trampoline */
326 NULL
, /* name_of_this */
327 false, /* la_store_sym_names_in_linkage_form_p */
328 cp_lookup_symbol_nonlocal
, /* lookup_symbol_nonlocal */
329 basic_lookup_transparent_type
,/* lookup_transparent_type */
331 /* We could support demangling here to provide module namespaces
332 also for inferiors with only minimal symbol table (ELF symbols).
333 Just the mangling standard is not standardized across compilers
334 and there is no DW_AT_producer available for inferiors with only
335 the ELF symbols to check the mangling kind. */
336 NULL
, /* Language specific symbol demangler */
338 NULL
, /* Language specific
339 class_name_from_physname */
340 f_op_print_tab
, /* expression operators for printing */
341 0, /* arrays are first-class (not c-style) */
342 1, /* String lower bound */
343 f_word_break_characters
,
344 f_collect_symbol_completion_matches
,
345 f_language_arch_info
,
346 default_print_array_index
,
347 default_pass_by_reference
,
349 c_watch_location_expression
,
350 NULL
, /* la_get_symbol_name_matcher */
351 iterate_over_symbols
,
352 default_search_name_hash
,
360 build_fortran_types (struct gdbarch
*gdbarch
)
362 struct builtin_f_type
*builtin_f_type
363 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
365 builtin_f_type
->builtin_void
366 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "VOID");
368 builtin_f_type
->builtin_character
369 = arch_integer_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
371 builtin_f_type
->builtin_logical_s1
372 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
374 builtin_f_type
->builtin_integer_s2
375 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
378 builtin_f_type
->builtin_logical_s2
379 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
382 builtin_f_type
->builtin_logical_s8
383 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
386 builtin_f_type
->builtin_integer
387 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
390 builtin_f_type
->builtin_logical
391 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
394 builtin_f_type
->builtin_real
395 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
396 "real", gdbarch_float_format (gdbarch
));
397 builtin_f_type
->builtin_real_s8
398 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
399 "real*8", gdbarch_double_format (gdbarch
));
400 builtin_f_type
->builtin_real_s16
401 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
402 "real*16", gdbarch_long_double_format (gdbarch
));
404 builtin_f_type
->builtin_complex_s8
405 = arch_complex_type (gdbarch
, "complex*8",
406 builtin_f_type
->builtin_real
);
407 builtin_f_type
->builtin_complex_s16
408 = arch_complex_type (gdbarch
, "complex*16",
409 builtin_f_type
->builtin_real_s8
);
410 builtin_f_type
->builtin_complex_s32
411 = arch_complex_type (gdbarch
, "complex*32",
412 builtin_f_type
->builtin_real_s16
);
414 return builtin_f_type
;
417 static struct gdbarch_data
*f_type_data
;
419 const struct builtin_f_type
*
420 builtin_f_type (struct gdbarch
*gdbarch
)
422 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
426 _initialize_f_language (void)
428 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);
434 fortran_argument_convert (struct value
*value
, bool is_artificial
)
438 /* If the value is not in the inferior e.g. registers values,
439 convenience variables and user input. */
440 if (VALUE_LVAL (value
) != lval_memory
)
442 struct type
*type
= value_type (value
);
443 const int length
= TYPE_LENGTH (type
);
445 = value_as_long (value_allocate_space_in_inferior (length
));
446 write_memory (addr
, value_contents (value
), length
);
448 = value_from_contents_and_address (type
, value_contents (value
),
450 return value_addr (val
);
453 return value_addr (value
); /* Program variables, e.g. arrays. */
461 fortran_preserve_arg_pointer (struct value
*arg
, struct type
*type
)
463 if (TYPE_CODE (value_type (arg
)) == TYPE_CODE_PTR
)
464 return value_type (arg
);