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 "f-lang.h" 31 #include "valprint.h" 32 #include "value.h" 33 #include "cp-support.h" 34 #include "charset.h" 35 #include "c-lang.h" 36 37 38 /* Local functions */ 39 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); 43 44 /* Return the encoding that should be used for the character type 45 TYPE. */ 46 47 static const char * 48 f_get_encoding (struct type *type) 49 { 50 const char *encoding; 51 52 switch (TYPE_LENGTH (type)) 53 { 54 case 1: 55 encoding = target_charset (get_type_arch (type)); 56 break; 57 case 4: 58 if (gdbarch_byte_order (get_type_arch (type)) == BFD_ENDIAN_BIG) 59 encoding = "UTF-32BE"; 60 else 61 encoding = "UTF-32LE"; 62 break; 63 64 default: 65 error (_("unrecognized character type")); 66 } 67 68 return encoding; 69 } 70 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. */ 76 77 static void 78 f_emit_char (int c, struct type *type, struct ui_file *stream, int quoter) 79 { 80 const char *encoding = f_get_encoding (type); 81 82 generic_emit_char (c, type, stream, quoter, encoding); 83 } 84 85 /* Implementation of la_printchar. */ 86 87 static void 88 f_printchar (int c, struct type *type, struct ui_file *stream) 89 { 90 fputs_filtered ("'", stream); 91 LA_EMIT_CHAR (c, type, stream, '\''); 92 fputs_filtered ("'", stream); 93 } 94 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. */ 101 102 static void 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) 106 { 107 const char *type_encoding = f_get_encoding (type); 108 109 if (TYPE_LENGTH (type) == 4) 110 fputs_filtered ("4_", stream); 111 112 if (!encoding || !*encoding) 113 encoding = type_encoding; 114 115 generic_printstr (stream, type, string, length, encoding, 116 force_ellipses, '\'', 0, options); 117 } 118 119 120 /* Table of operators and their precedences for printing expressions. */ 121 122 static const struct op_print f_op_print_tab[] = 123 { 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} 145 }; 146 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, 161 nr_f_primitive_types 162 }; 163 164 static void 165 f_language_arch_info (struct gdbarch *gdbarch, 166 struct language_arch_info *lai) 167 { 168 const struct builtin_f_type *builtin = builtin_f_type (gdbarch); 169 170 lai->string_char_type = builtin->builtin_character; 171 lai->primitive_type_vector 172 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1, 173 struct type *); 174 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; 197 198 lai->bool_type_symbol = "logical"; 199 lai->bool_type_default = builtin->builtin_logical_s2; 200 } 201 202 /* Remove the modules separator :: from the default break list. */ 203 204 static const char * 205 f_word_break_characters (void) 206 { 207 static char *retval; 208 209 if (!retval) 210 { 211 char *s; 212 213 retval = xstrdup (default_word_break_characters ()); 214 s = strchr (retval, ':'); 215 if (s) 216 { 217 char *last_char = &s[strlen (s) - 1]; 218 219 *s = *last_char; 220 *last_char = 0; 221 } 222 } 223 return retval; 224 } 225 226 /* Consider the modules separator :: as a valid symbol name character 227 class. */ 228 229 static void 230 f_collect_symbol_completion_matches (completion_tracker &tracker, 231 complete_symbol_mode mode, 232 symbol_name_match_type compare_name, 233 const char *text, const char *word, 234 enum type_code code) 235 { 236 default_collect_symbol_completion_matches_break_on (tracker, mode, 237 compare_name, 238 text, word, ":", code); 239 } 240 241 static const char *f_extensions[] = 242 { 243 ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP", 244 ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08", 245 NULL 246 }; 247 248 extern const struct language_defn f_language_defn = 249 { 250 "fortran", 251 "Fortran", 252 language_fortran, 253 range_check_on, 254 case_sensitive_off, 255 array_column_major, 256 macro_expansion_no, 257 f_extensions, 258 &exp_descriptor_standard, 259 f_parse, /* parser */ 260 null_post_parser, 261 f_printchar, /* Print character constant */ 262 f_printstr, /* function to print string constant */ 263 f_emit_char, /* Function to print a single character */ 264 f_print_type, /* Print a type using appropriate syntax */ 265 default_print_typedef, /* Print a typedef using appropriate syntax */ 266 f_val_print, /* Print a value using appropriate syntax */ 267 c_value_print, /* FIXME */ 268 default_read_var_value, /* la_read_var_value */ 269 NULL, /* Language specific skip_trampoline */ 270 NULL, /* name_of_this */ 271 false, /* la_store_sym_names_in_linkage_form_p */ 272 cp_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */ 273 basic_lookup_transparent_type,/* lookup_transparent_type */ 274 275 /* We could support demangling here to provide module namespaces 276 also for inferiors with only minimal symbol table (ELF symbols). 277 Just the mangling standard is not standardized across compilers 278 and there is no DW_AT_producer available for inferiors with only 279 the ELF symbols to check the mangling kind. */ 280 NULL, /* Language specific symbol demangler */ 281 NULL, 282 NULL, /* Language specific 283 class_name_from_physname */ 284 f_op_print_tab, /* expression operators for printing */ 285 0, /* arrays are first-class (not c-style) */ 286 1, /* String lower bound */ 287 f_word_break_characters, 288 f_collect_symbol_completion_matches, 289 f_language_arch_info, 290 default_print_array_index, 291 default_pass_by_reference, 292 default_get_string, 293 c_watch_location_expression, 294 NULL, /* la_get_symbol_name_matcher */ 295 iterate_over_symbols, 296 default_search_name_hash, 297 &default_varobj_ops, 298 NULL, 299 NULL, 300 LANG_MAGIC 301 }; 302 303 static void * 304 build_fortran_types (struct gdbarch *gdbarch) 305 { 306 struct builtin_f_type *builtin_f_type 307 = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type); 308 309 builtin_f_type->builtin_void 310 = arch_type (gdbarch, TYPE_CODE_VOID, TARGET_CHAR_BIT, "VOID"); 311 312 builtin_f_type->builtin_character 313 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character"); 314 315 builtin_f_type->builtin_logical_s1 316 = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1"); 317 318 builtin_f_type->builtin_integer_s2 319 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0, 320 "integer*2"); 321 322 builtin_f_type->builtin_logical_s2 323 = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1, 324 "logical*2"); 325 326 builtin_f_type->builtin_logical_s8 327 = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1, 328 "logical*8"); 329 330 builtin_f_type->builtin_integer 331 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, 332 "integer"); 333 334 builtin_f_type->builtin_logical 335 = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, 336 "logical*4"); 337 338 builtin_f_type->builtin_real 339 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), 340 "real", gdbarch_float_format (gdbarch)); 341 builtin_f_type->builtin_real_s8 342 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch), 343 "real*8", gdbarch_double_format (gdbarch)); 344 builtin_f_type->builtin_real_s16 345 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch), 346 "real*16", gdbarch_long_double_format (gdbarch)); 347 348 builtin_f_type->builtin_complex_s8 349 = arch_complex_type (gdbarch, "complex*8", 350 builtin_f_type->builtin_real); 351 builtin_f_type->builtin_complex_s16 352 = arch_complex_type (gdbarch, "complex*16", 353 builtin_f_type->builtin_real_s8); 354 builtin_f_type->builtin_complex_s32 355 = arch_complex_type (gdbarch, "complex*32", 356 builtin_f_type->builtin_real_s16); 357 358 return builtin_f_type; 359 } 360 361 static struct gdbarch_data *f_type_data; 362 363 const struct builtin_f_type * 364 builtin_f_type (struct gdbarch *gdbarch) 365 { 366 return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data); 367 } 368 369 void 370 _initialize_f_language (void) 371 { 372 f_type_data = gdbarch_data_register_post_init (build_fortran_types); 373 } 374