contrib/gdb-7/gdb/f-lang.c

   1 /* Fortran language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-2015 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, 0, 0, 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 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 const struct language_defn f_language_defn =
 239 {
 240   "fortran",
 241   "Fortran",
 242   language_fortran,
 243   range_check_on,
 244   case_sensitive_off,
 245   array_column_major,
 246   macro_expansion_no,
 247   &exp_descriptor_standard,
 248   f_parse,                      /* parser */
 249   f_error,                      /* parser error function */
 250   null_post_parser,
 251   f_printchar,                  /* Print character constant */
 252   f_printstr,                   /* function to print string constant */
 253   f_emit_char,                  /* Function to print a single character */
 254   f_print_type,                 /* Print a type using appropriate syntax */
 255   default_print_typedef,        /* Print a typedef using appropriate syntax */
 256   f_val_print,                  /* Print a value using appropriate syntax */
 257   c_value_print,                /* FIXME */
 258   default_read_var_value,       /* la_read_var_value */
 259   NULL,                         /* Language specific skip_trampoline */
 260   NULL,                         /* name_of_this */
 261   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 262   basic_lookup_transparent_type,/* lookup_transparent_type */
 263   NULL,                         /* Language specific symbol demangler */
 264   NULL,                         /* Language specific
 265                                    class_name_from_physname */
 266   f_op_print_tab,               /* expression operators for printing */
 267   0,                            /* arrays are first-class (not c-style) */
 268   1,                            /* String lower bound */
 269   f_word_break_characters,
 270   f_make_symbol_completion_list,
 271   f_language_arch_info,
 272   default_print_array_index,
 273   default_pass_by_reference,
 274   default_get_string,
 275   NULL,                         /* la_get_symbol_name_cmp */
 276   iterate_over_symbols,
 277   &default_varobj_ops,
 278   NULL,
 279   NULL,
 280   LANG_MAGIC
 281 };
 282
 283 static void *
 284 build_fortran_types (struct gdbarch *gdbarch)
 285 {
 286   struct builtin_f_type *builtin_f_type
 287     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 288
 289   builtin_f_type->builtin_void
 290     = arch_type (gdbarch, TYPE_CODE_VOID, 1, "VOID");
 291
 292   builtin_f_type->builtin_character
 293     = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
 294
 295   builtin_f_type->builtin_logical_s1
 296     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 297
 298   builtin_f_type->builtin_integer_s2
 299     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 300                          "integer*2");
 301
 302   builtin_f_type->builtin_logical_s2
 303     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 304                          "logical*2");
 305
 306   builtin_f_type->builtin_logical_s8
 307     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 308                          "logical*8");
 309
 310   builtin_f_type->builtin_integer
 311     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 312                          "integer");
 313
 314   builtin_f_type->builtin_logical
 315     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 316                          "logical*4");
 317
 318   builtin_f_type->builtin_real
 319     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 320                        "real", NULL);
 321   builtin_f_type->builtin_real_s8
 322     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 323                        "real*8", NULL);
 324   builtin_f_type->builtin_real_s16
 325     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 326                        "real*16", NULL);
 327
 328   builtin_f_type->builtin_complex_s8
 329     = arch_complex_type (gdbarch, "complex*8",
 330                          builtin_f_type->builtin_real);
 331   builtin_f_type->builtin_complex_s16
 332     = arch_complex_type (gdbarch, "complex*16",
 333                          builtin_f_type->builtin_real_s8);
 334   builtin_f_type->builtin_complex_s32
 335     = arch_complex_type (gdbarch, "complex*32",
 336                          builtin_f_type->builtin_real_s16);
 337
 338   return builtin_f_type;
 339 }
 340
 341 static struct gdbarch_data *f_type_data;
 342
 343 const struct builtin_f_type *
 344 builtin_f_type (struct gdbarch *gdbarch)
 345 {
 346   return gdbarch_data (gdbarch, f_type_data);
 347 }
 348
 349 void
 350 _initialize_f_language (void)
 351 {
 352   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 353
 354   add_language (&f_language_defn);
 355 }