gdb/f-lang.c

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