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 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 \f
 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 \f
 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                                      const char *text, const char *word,
 233                                      enum type_code code)
 234 {
 235   default_collect_symbol_completion_matches_break_on (tracker, mode,
 236                                                       text, word, ":", code);
 237 }
 238
 239 static const char *f_extensions[] =
 240 {
 241   ".f", ".F", ".for", ".FOR", ".ftn", ".FTN", ".fpp", ".FPP",
 242   ".f90", ".F90", ".f95", ".F95", ".f03", ".F03", ".f08", ".F08",
 243   NULL
 244 };
 245
 246 extern const struct language_defn f_language_defn =
 247 {
 248   "fortran",
 249   "Fortran",
 250   language_fortran,
 251   range_check_on,
 252   case_sensitive_off,
 253   array_column_major,
 254   macro_expansion_no,
 255   f_extensions,
 256   &exp_descriptor_standard,
 257   f_parse,                      /* parser */
 258   f_yyerror,                    /* parser error function */
 259   null_post_parser,
 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 */
 272
 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 */
 279   NULL,
 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,
 290   default_get_string,
 291   c_watch_location_expression,
 292   NULL,                         /* la_get_symbol_name_cmp */
 293   iterate_over_symbols,
 294   &default_varobj_ops,
 295   NULL,
 296   NULL,
 297   LANG_MAGIC
 298 };
 299
 300 static void *
 301 build_fortran_types (struct gdbarch *gdbarch)
 302 {
 303   struct builtin_f_type *builtin_f_type
 304     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 305
 306   builtin_f_type->builtin_void
 307     = arch_type (gdbarch, TYPE_CODE_VOID, 1, "VOID");
 308
 309   builtin_f_type->builtin_character
 310     = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
 311
 312   builtin_f_type->builtin_logical_s1
 313     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 314
 315   builtin_f_type->builtin_integer_s2
 316     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 317                          "integer*2");
 318
 319   builtin_f_type->builtin_logical_s2
 320     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 321                          "logical*2");
 322
 323   builtin_f_type->builtin_logical_s8
 324     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 325                          "logical*8");
 326
 327   builtin_f_type->builtin_integer
 328     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 329                          "integer");
 330
 331   builtin_f_type->builtin_logical
 332     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 333                          "logical*4");
 334
 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));
 344
 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);
 354
 355   return builtin_f_type;
 356 }
 357
 358 static struct gdbarch_data *f_type_data;
 359
 360 const struct builtin_f_type *
 361 builtin_f_type (struct gdbarch *gdbarch)
 362 {
 363   return (const struct builtin_f_type *) gdbarch_data (gdbarch, f_type_data);
 364 }
 365
 366 void
 367 _initialize_f_language (void)
 368 {
 369   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 370 }