1 /* Fortran language support routines for GDB, the GNU debugger. 2 3 Copyright (C) 1993-2017 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 extern void _initialize_f_language (void); 41 42 static void f_printchar (int c, struct type *type, struct ui_file * stream); 43 static void f_emit_char (int c, struct type *type, 44 struct ui_file * stream, int quoter); 45 46 /* Return the encoding that should be used for the character type 47 TYPE. */ 48 49 static const char * 50 f_get_encoding (struct type *type) 51 { 52 const char *encoding; 53 54 switch (TYPE_LENGTH (type)) 55 { 56 case 1: 57 encoding = target_charset (get_type_arch (type)); 58 break; 59 case 4: 60 if (gdbarch_byte_order (get_type_arch (type)) == BFD_ENDIAN_BIG) 61 encoding = "UTF-32BE"; 62 else 63 encoding = "UTF-32LE"; 64 break; 65 66 default: 67 error (_("unrecognized character type")); 68 } 69 70 return encoding; 71 } 72 73 /* Print the character C on STREAM as part of the contents of a literal 74 string whose delimiter is QUOTER. Note that that format for printing 75 characters and strings is language specific. 76 FIXME: This is a copy of the same function from c-exp.y. It should 77 be replaced with a true F77 version. */ 78 79 static void 80 f_emit_char (int c, struct type *type, struct ui_file *stream, int quoter) 81 { 82 const char *encoding = f_get_encoding (type); 83 84 generic_emit_char (c, type, stream, quoter, encoding); 85 } 86 87 /* Implementation of la_printchar. */ 88 89 static void 90 f_printchar (int c, struct type *type, struct ui_file *stream) 91 { 92 fputs_filtered ("'", stream); 93 LA_EMIT_CHAR (c, type, stream, '\''); 94 fputs_filtered ("'", stream); 95 } 96 97 /* Print the character string STRING, printing at most LENGTH characters. 98 Printing stops early if the number hits print_max; repeat counts 99 are printed as appropriate. Print ellipses at the end if we 100 had to stop before printing LENGTH characters, or if FORCE_ELLIPSES. 101 FIXME: This is a copy of the same function from c-exp.y. It should 102 be replaced with a true F77 version. */ 103 104 static void 105 f_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string, 106 unsigned int length, const char *encoding, int force_ellipses, 107 const struct value_print_options *options) 108 { 109 const char *type_encoding = f_get_encoding (type); 110 111 if (TYPE_LENGTH (type) == 4) 112 fputs_filtered ("4_", stream); 113 114 if (!encoding || !*encoding) 115 encoding = type_encoding; 116 117 generic_printstr (stream, type, string, length, encoding, 118 force_ellipses, '\'', 0, options); 119 } 120 121 122 /* Table of operators and their precedences for printing expressions. */ 123 124 static const struct op_print f_op_print_tab[] = 125 { 126 {"+", BINOP_ADD, PREC_ADD, 0}, 127 {"+", UNOP_PLUS, PREC_PREFIX, 0}, 128 {"-", BINOP_SUB, PREC_ADD, 0}, 129 {"-", UNOP_NEG, PREC_PREFIX, 0}, 130 {"*", BINOP_MUL, PREC_MUL, 0}, 131 {"/", BINOP_DIV, PREC_MUL, 0}, 132 {"DIV", BINOP_INTDIV, PREC_MUL, 0}, 133 {"MOD", BINOP_REM, PREC_MUL, 0}, 134 {"=", BINOP_ASSIGN, PREC_ASSIGN, 1}, 135 {".OR.", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0}, 136 {".AND.", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0}, 137 {".NOT.", UNOP_LOGICAL_NOT, PREC_PREFIX, 0}, 138 {".EQ.", BINOP_EQUAL, PREC_EQUAL, 0}, 139 {".NE.", BINOP_NOTEQUAL, PREC_EQUAL, 0}, 140 {".LE.", BINOP_LEQ, PREC_ORDER, 0}, 141 {".GE.", BINOP_GEQ, PREC_ORDER, 0}, 142 {".GT.", BINOP_GTR, PREC_ORDER, 0}, 143 {".LT.", BINOP_LESS, PREC_ORDER, 0}, 144 {"**", UNOP_IND, PREC_PREFIX, 0}, 145 {"@", BINOP_REPEAT, PREC_REPEAT, 0}, 146 {NULL, OP_NULL, PREC_REPEAT, 0} 147 }; 148 149 enum f_primitive_types { 150 f_primitive_type_character, 151 f_primitive_type_logical, 152 f_primitive_type_logical_s1, 153 f_primitive_type_logical_s2, 154 f_primitive_type_logical_s8, 155 f_primitive_type_integer, 156 f_primitive_type_integer_s2, 157 f_primitive_type_real, 158 f_primitive_type_real_s8, 159 f_primitive_type_real_s16, 160 f_primitive_type_complex_s8, 161 f_primitive_type_complex_s16, 162 f_primitive_type_void, 163 nr_f_primitive_types 164 }; 165 166 static void 167 f_language_arch_info (struct gdbarch *gdbarch, 168 struct language_arch_info *lai) 169 { 170 const struct builtin_f_type *builtin = builtin_f_type (gdbarch); 171 172 lai->string_char_type = builtin->builtin_character; 173 lai->primitive_type_vector 174 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_f_primitive_types + 1, 175 struct type *); 176 177 lai->primitive_type_vector [f_primitive_type_character] 178 = builtin->builtin_character; 179 lai->primitive_type_vector [f_primitive_type_logical] 180 = builtin->builtin_logical; 181 lai->primitive_type_vector [f_primitive_type_logical_s1] 182 = builtin->builtin_logical_s1; 183 lai->primitive_type_vector [f_primitive_type_logical_s2] 184 = builtin->builtin_logical_s2; 185 lai->primitive_type_vector [f_primitive_type_logical_s8] 186 = builtin->builtin_logical_s8; 187 lai->primitive_type_vector [f_primitive_type_real] 188 = builtin->builtin_real; 189 lai->primitive_type_vector [f_primitive_type_real_s8] 190 = builtin->builtin_real_s8; 191 lai->primitive_type_vector [f_primitive_type_real_s16] 192 = builtin->builtin_real_s16; 193 lai->primitive_type_vector [f_primitive_type_complex_s8] 194 = builtin->builtin_complex_s8; 195 lai->primitive_type_vector [f_primitive_type_complex_s16] 196 = builtin->builtin_complex_s16; 197 lai->primitive_type_vector [f_primitive_type_void] 198 = builtin->builtin_void; 199 200 lai->bool_type_symbol = "logical"; 201 lai->bool_type_default = builtin->builtin_logical_s2; 202 } 203 204 /* Remove the modules separator :: from the default break list. */ 205 206 static const char * 207 f_word_break_characters (void) 208 { 209 static char *retval; 210 211 if (!retval) 212 { 213 char *s; 214 215 retval = xstrdup (default_word_break_characters ()); 216 s = strchr (retval, ':'); 217 if (s) 218 { 219 char *last_char = &s[strlen (s) - 1]; 220 221 *s = *last_char; 222 *last_char = 0; 223 } 224 } 225 return retval; 226 } 227 228 /* Consider the modules separator :: as a valid symbol name character 229 class. */ 230 231 static VEC (char_ptr) * 232 f_make_symbol_completion_list (const char *text, const char *word, 233 enum type_code code) 234 { 235 return default_make_symbol_completion_list_break_on (text, word, ":", code); 236 } 237 238 static const char *f_extensions[] = 239 { 240 ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP", 241 ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08", 242 NULL 243 }; 244 245 const struct language_defn f_language_defn = 246 { 247 "fortran", 248 "Fortran", 249 language_fortran, 250 range_check_on, 251 case_sensitive_off, 252 array_column_major, 253 macro_expansion_no, 254 f_extensions, 255 &exp_descriptor_standard, 256 f_parse, /* parser */ 257 f_yyerror, /* parser error function */ 258 null_post_parser, 259 f_printchar, /* Print character constant */ 260 f_printstr, /* function to print string constant */ 261 f_emit_char, /* Function to print a single character */ 262 f_print_type, /* Print a type using appropriate syntax */ 263 default_print_typedef, /* Print a typedef using appropriate syntax */ 264 f_val_print, /* Print a value using appropriate syntax */ 265 c_value_print, /* FIXME */ 266 default_read_var_value, /* la_read_var_value */ 267 NULL, /* Language specific skip_trampoline */ 268 NULL, /* name_of_this */ 269 cp_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */ 270 basic_lookup_transparent_type,/* lookup_transparent_type */ 271 272 /* We could support demangling here to provide module namespaces 273 also for inferiors with only minimal symbol table (ELF symbols). 274 Just the mangling standard is not standardized across compilers 275 and there is no DW_AT_producer available for inferiors with only 276 the ELF symbols to check the mangling kind. */ 277 NULL, /* Language specific symbol demangler */ 278 NULL, 279 NULL, /* Language specific 280 class_name_from_physname */ 281 f_op_print_tab, /* expression operators for printing */ 282 0, /* arrays are first-class (not c-style) */ 283 1, /* String lower bound */ 284 f_word_break_characters, 285 f_make_symbol_completion_list, 286 f_language_arch_info, 287 default_print_array_index, 288 default_pass_by_reference, 289 default_get_string, 290 NULL, /* la_get_symbol_name_cmp */ 291 iterate_over_symbols, 292 &default_varobj_ops, 293 NULL, 294 NULL, 295 LANG_MAGIC 296 }; 297 298 static void * 299 build_fortran_types (struct gdbarch *gdbarch) 300 { 301 struct builtin_f_type *builtin_f_type 302 = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type); 303 304 builtin_f_type->builtin_void 305 = arch_type (gdbarch, TYPE_CODE_VOID, 1, "VOID"); 306 307 builtin_f_type->builtin_character 308 = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character"); 309 310 builtin_f_type->builtin_logical_s1 311 = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1"); 312 313 builtin_f_type->builtin_integer_s2 314 = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0, 315 "integer*2"); 316 317 builtin_f_type->builtin_logical_s2 318 = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1, 319 "logical*2"); 320 321 builtin_f_type->builtin_logical_s8 322 = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1, 323 "logical*8"); 324 325 builtin_f_type->builtin_integer 326 = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, 327 "integer"); 328 329 builtin_f_type->builtin_logical 330 = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, 331 "logical*4"); 332 333 builtin_f_type->builtin_real 334 = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), 335 "real", gdbarch_float_format (gdbarch)); 336 builtin_f_type->builtin_real_s8 337 = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch), 338 "real*8", gdbarch_double_format (gdbarch)); 339 builtin_f_type->builtin_real_s16 340 = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch), 341 "real*16", gdbarch_long_double_format (gdbarch)); 342 343 builtin_f_type->builtin_complex_s8 344 = arch_complex_type (gdbarch, "complex*8", 345 builtin_f_type->builtin_real); 346 builtin_f_type->builtin_complex_s16 347 = arch_complex_type (gdbarch, "complex*16", 348 builtin_f_type->builtin_real_s8); 349 builtin_f_type->builtin_complex_s32 350 = arch_complex_type (gdbarch, "complex*32", 351 builtin_f_type->builtin_real_s16); 352 353 return builtin_f_type; 354 } 355 356 static struct gdbarch_data *f_type_data; 357 358 const struct builtin_f_type * 359 builtin_f_type (struct gdbarch *gdbarch) 360 { 361 return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data); 362 } 363 364 void 365 _initialize_f_language (void) 366 { 367 f_type_data = gdbarch_data_register_post_init (build_fortran_types); 368 369 add_language (&f_language_defn); 370 } 371