1 /* Fortran language support routines for GDB, the GNU debugger.
3 Copyright (C) 1993-2017 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"
33 #include "cp-support.h"
40 static void f_printchar (int c
, struct type
*type
, struct ui_file
* stream
);
41 static void f_emit_char (int c
, struct type
*type
,
42 struct ui_file
* stream
, int quoter
);
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 (gdbarch_byte_order (get_type_arch (type
)) == BFD_ENDIAN_BIG
)
59 encoding
= "UTF-32BE";
61 encoding
= "UTF-32LE";
65 error (_("unrecognized character type"));
71 /* Print the character C on STREAM as part of the contents of a literal
72 string whose delimiter is QUOTER. Note that that format for printing
73 characters and strings is language specific.
74 FIXME: This is a copy of the same function from c-exp.y. It should
75 be replaced with a true F77 version. */
78 f_emit_char (int c
, struct type
*type
, struct ui_file
*stream
, int quoter
)
80 const char *encoding
= f_get_encoding (type
);
82 generic_emit_char (c
, type
, stream
, quoter
, encoding
);
85 /* Implementation of la_printchar. */
88 f_printchar (int c
, struct type
*type
, struct ui_file
*stream
)
90 fputs_filtered ("'", stream
);
91 LA_EMIT_CHAR (c
, type
, stream
, '\'');
92 fputs_filtered ("'", stream
);
95 /* Print the character string STRING, printing at most LENGTH characters.
96 Printing stops early if the number hits print_max; repeat counts
97 are printed as appropriate. Print ellipses at the end if we
98 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
99 FIXME: This is a copy of the same function from c-exp.y. It should
100 be replaced with a true F77 version. */
103 f_printstr (struct ui_file
*stream
, struct type
*type
, const gdb_byte
*string
,
104 unsigned int length
, const char *encoding
, int force_ellipses
,
105 const struct value_print_options
*options
)
107 const char *type_encoding
= f_get_encoding (type
);
109 if (TYPE_LENGTH (type
) == 4)
110 fputs_filtered ("4_", stream
);
112 if (!encoding
|| !*encoding
)
113 encoding
= type_encoding
;
115 generic_printstr (stream
, type
, string
, length
, encoding
,
116 force_ellipses
, '\'', 0, options
);
120 /* Table of operators and their precedences for printing expressions. */
122 static const struct op_print f_op_print_tab
[] =
124 {"+", BINOP_ADD
, PREC_ADD
, 0},
125 {"+", UNOP_PLUS
, PREC_PREFIX
, 0},
126 {"-", BINOP_SUB
, PREC_ADD
, 0},
127 {"-", UNOP_NEG
, PREC_PREFIX
, 0},
128 {"*", BINOP_MUL
, PREC_MUL
, 0},
129 {"/", BINOP_DIV
, PREC_MUL
, 0},
130 {"DIV", BINOP_INTDIV
, PREC_MUL
, 0},
131 {"MOD", BINOP_REM
, PREC_MUL
, 0},
132 {"=", BINOP_ASSIGN
, PREC_ASSIGN
, 1},
133 {".OR.", BINOP_LOGICAL_OR
, PREC_LOGICAL_OR
, 0},
134 {".AND.", BINOP_LOGICAL_AND
, PREC_LOGICAL_AND
, 0},
135 {".NOT.", UNOP_LOGICAL_NOT
, PREC_PREFIX
, 0},
136 {".EQ.", BINOP_EQUAL
, PREC_EQUAL
, 0},
137 {".NE.", BINOP_NOTEQUAL
, PREC_EQUAL
, 0},
138 {".LE.", BINOP_LEQ
, PREC_ORDER
, 0},
139 {".GE.", BINOP_GEQ
, PREC_ORDER
, 0},
140 {".GT.", BINOP_GTR
, PREC_ORDER
, 0},
141 {".LT.", BINOP_LESS
, PREC_ORDER
, 0},
142 {"**", UNOP_IND
, PREC_PREFIX
, 0},
143 {"@", BINOP_REPEAT
, PREC_REPEAT
, 0},
144 {NULL
, OP_NULL
, PREC_REPEAT
, 0}
147 enum f_primitive_types
{
148 f_primitive_type_character
,
149 f_primitive_type_logical
,
150 f_primitive_type_logical_s1
,
151 f_primitive_type_logical_s2
,
152 f_primitive_type_logical_s8
,
153 f_primitive_type_integer
,
154 f_primitive_type_integer_s2
,
155 f_primitive_type_real
,
156 f_primitive_type_real_s8
,
157 f_primitive_type_real_s16
,
158 f_primitive_type_complex_s8
,
159 f_primitive_type_complex_s16
,
160 f_primitive_type_void
,
165 f_language_arch_info (struct gdbarch
*gdbarch
,
166 struct language_arch_info
*lai
)
168 const struct builtin_f_type
*builtin
= builtin_f_type (gdbarch
);
170 lai
->string_char_type
= builtin
->builtin_character
;
171 lai
->primitive_type_vector
172 = GDBARCH_OBSTACK_CALLOC (gdbarch
, nr_f_primitive_types
+ 1,
175 lai
->primitive_type_vector
[f_primitive_type_character
]
176 = builtin
->builtin_character
;
177 lai
->primitive_type_vector
[f_primitive_type_logical
]
178 = builtin
->builtin_logical
;
179 lai
->primitive_type_vector
[f_primitive_type_logical_s1
]
180 = builtin
->builtin_logical_s1
;
181 lai
->primitive_type_vector
[f_primitive_type_logical_s2
]
182 = builtin
->builtin_logical_s2
;
183 lai
->primitive_type_vector
[f_primitive_type_logical_s8
]
184 = builtin
->builtin_logical_s8
;
185 lai
->primitive_type_vector
[f_primitive_type_real
]
186 = builtin
->builtin_real
;
187 lai
->primitive_type_vector
[f_primitive_type_real_s8
]
188 = builtin
->builtin_real_s8
;
189 lai
->primitive_type_vector
[f_primitive_type_real_s16
]
190 = builtin
->builtin_real_s16
;
191 lai
->primitive_type_vector
[f_primitive_type_complex_s8
]
192 = builtin
->builtin_complex_s8
;
193 lai
->primitive_type_vector
[f_primitive_type_complex_s16
]
194 = builtin
->builtin_complex_s16
;
195 lai
->primitive_type_vector
[f_primitive_type_void
]
196 = builtin
->builtin_void
;
198 lai
->bool_type_symbol
= "logical";
199 lai
->bool_type_default
= builtin
->builtin_logical_s2
;
202 /* Remove the modules separator :: from the default break list. */
205 f_word_break_characters (void)
213 retval
= xstrdup (default_word_break_characters ());
214 s
= strchr (retval
, ':');
217 char *last_char
= &s
[strlen (s
) - 1];
226 /* Consider the modules separator :: as a valid symbol name character
230 f_collect_symbol_completion_matches (completion_tracker
&tracker
,
231 complete_symbol_mode mode
,
232 const char *text
, const char *word
,
235 default_collect_symbol_completion_matches_break_on (tracker
, mode
,
236 text
, word
, ":", code
);
239 static const char *f_extensions
[] =
241 ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
242 ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
246 extern const struct language_defn f_language_defn
=
256 &exp_descriptor_standard
,
257 f_parse
, /* parser */
258 f_yyerror
, /* parser error function */
260 f_printchar
, /* Print character constant */
261 f_printstr
, /* function to print string constant */
262 f_emit_char
, /* Function to print a single character */
263 f_print_type
, /* Print a type using appropriate syntax */
264 default_print_typedef
, /* Print a typedef using appropriate syntax */
265 f_val_print
, /* Print a value using appropriate syntax */
266 c_value_print
, /* FIXME */
267 default_read_var_value
, /* la_read_var_value */
268 NULL
, /* Language specific skip_trampoline */
269 NULL
, /* name_of_this */
270 cp_lookup_symbol_nonlocal
, /* lookup_symbol_nonlocal */
271 basic_lookup_transparent_type
,/* lookup_transparent_type */
273 /* We could support demangling here to provide module namespaces
274 also for inferiors with only minimal symbol table (ELF symbols).
275 Just the mangling standard is not standardized across compilers
276 and there is no DW_AT_producer available for inferiors with only
277 the ELF symbols to check the mangling kind. */
278 NULL
, /* Language specific symbol demangler */
280 NULL
, /* Language specific
281 class_name_from_physname */
282 f_op_print_tab
, /* expression operators for printing */
283 0, /* arrays are first-class (not c-style) */
284 1, /* String lower bound */
285 f_word_break_characters
,
286 f_collect_symbol_completion_matches
,
287 f_language_arch_info
,
288 default_print_array_index
,
289 default_pass_by_reference
,
291 c_watch_location_expression
,
292 NULL
, /* la_get_symbol_name_cmp */
293 iterate_over_symbols
,
301 build_fortran_types (struct gdbarch
*gdbarch
)
303 struct builtin_f_type
*builtin_f_type
304 = GDBARCH_OBSTACK_ZALLOC (gdbarch
, struct builtin_f_type
);
306 builtin_f_type
->builtin_void
307 = arch_type (gdbarch
, TYPE_CODE_VOID
, TARGET_CHAR_BIT
, "VOID");
309 builtin_f_type
->builtin_character
310 = arch_integer_type (gdbarch
, TARGET_CHAR_BIT
, 0, "character");
312 builtin_f_type
->builtin_logical_s1
313 = arch_boolean_type (gdbarch
, TARGET_CHAR_BIT
, 1, "logical*1");
315 builtin_f_type
->builtin_integer_s2
316 = arch_integer_type (gdbarch
, gdbarch_short_bit (gdbarch
), 0,
319 builtin_f_type
->builtin_logical_s2
320 = arch_boolean_type (gdbarch
, gdbarch_short_bit (gdbarch
), 1,
323 builtin_f_type
->builtin_logical_s8
324 = arch_boolean_type (gdbarch
, gdbarch_long_long_bit (gdbarch
), 1,
327 builtin_f_type
->builtin_integer
328 = arch_integer_type (gdbarch
, gdbarch_int_bit (gdbarch
), 0,
331 builtin_f_type
->builtin_logical
332 = arch_boolean_type (gdbarch
, gdbarch_int_bit (gdbarch
), 1,
335 builtin_f_type
->builtin_real
336 = arch_float_type (gdbarch
, gdbarch_float_bit (gdbarch
),
337 "real", gdbarch_float_format (gdbarch
));
338 builtin_f_type
->builtin_real_s8
339 = arch_float_type (gdbarch
, gdbarch_double_bit (gdbarch
),
340 "real*8", gdbarch_double_format (gdbarch
));
341 builtin_f_type
->builtin_real_s16
342 = arch_float_type (gdbarch
, gdbarch_long_double_bit (gdbarch
),
343 "real*16", gdbarch_long_double_format (gdbarch
));
345 builtin_f_type
->builtin_complex_s8
346 = arch_complex_type (gdbarch
, "complex*8",
347 builtin_f_type
->builtin_real
);
348 builtin_f_type
->builtin_complex_s16
349 = arch_complex_type (gdbarch
, "complex*16",
350 builtin_f_type
->builtin_real_s8
);
351 builtin_f_type
->builtin_complex_s32
352 = arch_complex_type (gdbarch
, "complex*32",
353 builtin_f_type
->builtin_real_s16
);
355 return builtin_f_type
;
358 static struct gdbarch_data
*f_type_data
;
360 const struct builtin_f_type
*
361 builtin_f_type (struct gdbarch
*gdbarch
)
363 return (const struct builtin_f_type
*) gdbarch_data (gdbarch
, f_type_data
);
367 _initialize_f_language (void)
369 f_type_data
= gdbarch_data_register_post_init (build_fortran_types
);