gdb/f-lang.c

   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 \f
 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 \f
 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 void
 232 f_collect_symbol_completion_matches (completion_tracker &tracker,
 233                                      const char *text, const char *word,
 234                                      enum type_code code)
 235 {
 236   default_collect_symbol_completion_matches_break_on (tracker,
 237                                                       text, word, ":", code);
 238 }
 239
 240 static const char *f_extensions[] =
 241 {
 242   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 243   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 244   NULL
 245 };
 246
 247 const struct language_defn f_language_defn =
 248 {
 249   "fortran",
 250   "Fortran",
 251   language_fortran,
 252   range_check_on,
 253   case_sensitive_off,
 254   array_column_major,
 255   macro_expansion_no,
 256   f_extensions,
 257   &exp_descriptor_standard,
 258   f_parse,                      /* parser */
 259   f_yyerror,                    /* parser error function */
 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   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 272   basic_lookup_transparent_type,/* lookup_transparent_type */
 273
 274   /* We could support demangling here to provide module namespaces
 275      also for inferiors with only minimal symbol table (ELF symbols).
 276      Just the mangling standard is not standardized across compilers
 277      and there is no DW_AT_producer available for inferiors with only
 278      the ELF symbols to check the mangling kind.  */
 279   NULL,                         /* Language specific symbol demangler */
 280   NULL,
 281   NULL,                         /* Language specific
 282                                    class_name_from_physname */
 283   f_op_print_tab,               /* expression operators for printing */
 284   0,                            /* arrays are first-class (not c-style) */
 285   1,                            /* String lower bound */
 286   f_word_break_characters,
 287   f_collect_symbol_completion_matches,
 288   f_language_arch_info,
 289   default_print_array_index,
 290   default_pass_by_reference,
 291   default_get_string,
 292   c_watch_location_expression,
 293   NULL,                         /* la_get_symbol_name_cmp */
 294   iterate_over_symbols,
 295   &default_varobj_ops,
 296   NULL,
 297   NULL,
 298   LANG_MAGIC
 299 };
 300
 301 static void *
 302 build_fortran_types (struct gdbarch *gdbarch)
 303 {
 304   struct builtin_f_type *builtin_f_type
 305     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 306
 307   builtin_f_type->builtin_void
 308     = arch_type (gdbarch, TYPE_CODE_VOID, 1, "VOID");
 309
 310   builtin_f_type->builtin_character
 311     = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
 312
 313   builtin_f_type->builtin_logical_s1
 314     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 315
 316   builtin_f_type->builtin_integer_s2
 317     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 318                          "integer*2");
 319
 320   builtin_f_type->builtin_logical_s2
 321     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 322                          "logical*2");
 323
 324   builtin_f_type->builtin_logical_s8
 325     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 326                          "logical*8");
 327
 328   builtin_f_type->builtin_integer
 329     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 330                          "integer");
 331
 332   builtin_f_type->builtin_logical
 333     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 334                          "logical*4");
 335
 336   builtin_f_type->builtin_real
 337     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 338                        "real", gdbarch_float_format (gdbarch));
 339   builtin_f_type->builtin_real_s8
 340     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 341                        "real*8", gdbarch_double_format (gdbarch));
 342   builtin_f_type->builtin_real_s16
 343     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 344                        "real*16", gdbarch_long_double_format (gdbarch));
 345
 346   builtin_f_type->builtin_complex_s8
 347     = arch_complex_type (gdbarch, "complex*8",
 348                          builtin_f_type->builtin_real);
 349   builtin_f_type->builtin_complex_s16
 350     = arch_complex_type (gdbarch, "complex*16",
 351                          builtin_f_type->builtin_real_s8);
 352   builtin_f_type->builtin_complex_s32
 353     = arch_complex_type (gdbarch, "complex*32",
 354                          builtin_f_type->builtin_real_s16);
 355
 356   return builtin_f_type;
 357 }
 358
 359 static struct gdbarch_data *f_type_data;
 360
 361 const struct builtin_f_type *
 362 builtin_f_type (struct gdbarch *gdbarch)
 363 {
 364   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 365 }
 366
 367 void
 368 _initialize_f_language (void)
 369 {
 370   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 371
 372   add_language (&f_language_defn);
 373 }