gdb/f-lang.c

   1 /* Fortran language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1993-1996, 1998-2005, 2007-2012 Free Software
   4    Foundation, Inc.
   5
   6    Contributed by Motorola.  Adapted from the C parser by Farooq Butt
   7    (fmbutt@engage.sps.mot.com).
   8
   9    This file is part of GDB.
  10
  11    This program is free software; you can redistribute it and/or modify
  12    it under the terms of the GNU General Public License as published by
  13    the Free Software Foundation; either version 3 of the License, or
  14    (at your option) any later version.
  15
  16    This program is distributed in the hope that it will be useful,
  17    but WITHOUT ANY WARRANTY; without even the implied warranty of
  18    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19    GNU General Public License for more details.
  20
  21    You should have received a copy of the GNU General Public License
  22    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  23
  24 #include "defs.h"
  25 #include "gdb_string.h"
  26 #include "symtab.h"
  27 #include "gdbtypes.h"
  28 #include "expression.h"
  29 #include "parser-defs.h"
  30 #include "language.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 (char *text, char *word)
 234 {
 235   return default_make_symbol_completion_list_break_on (text, word, ":");
 236 }
 237
 238 const struct language_defn f_language_defn =
 239 {
 240   "fortran",
 241   language_fortran,
 242   range_check_on,
 243   case_sensitive_off,
 244   array_column_major,
 245   macro_expansion_no,
 246   &exp_descriptor_standard,
 247   f_parse,                      /* parser */
 248   f_error,                      /* parser error function */
 249   null_post_parser,
 250   f_printchar,                  /* Print character constant */
 251   f_printstr,                   /* function to print string constant */
 252   f_emit_char,                  /* Function to print a single character */
 253   f_print_type,                 /* Print a type using appropriate syntax */
 254   default_print_typedef,        /* Print a typedef using appropriate syntax */
 255   f_val_print,                  /* Print a value using appropriate syntax */
 256   c_value_print,                /* FIXME */
 257   default_read_var_value,       /* la_read_var_value */
 258   NULL,                         /* Language specific skip_trampoline */
 259   NULL,                         /* name_of_this */
 260   cp_lookup_symbol_nonlocal,    /* lookup_symbol_nonlocal */
 261   basic_lookup_transparent_type,/* lookup_transparent_type */
 262   NULL,                         /* Language specific symbol demangler */
 263   NULL,                         /* Language specific
 264                                    class_name_from_physname */
 265   f_op_print_tab,               /* expression operators for printing */
 266   0,                            /* arrays are first-class (not c-style) */
 267   1,                            /* String lower bound */
 268   f_word_break_characters,
 269   f_make_symbol_completion_list,
 270   f_language_arch_info,
 271   default_print_array_index,
 272   default_pass_by_reference,
 273   default_get_string,
 274   NULL,                         /* la_get_symbol_name_cmp */
 275   iterate_over_symbols,
 276   LANG_MAGIC
 277 };
 278
 279 static void *
 280 build_fortran_types (struct gdbarch *gdbarch)
 281 {
 282   struct builtin_f_type *builtin_f_type
 283     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_f_type);
 284
 285   builtin_f_type->builtin_void
 286     = arch_type (gdbarch, TYPE_CODE_VOID, 1, "VOID");
 287
 288   builtin_f_type->builtin_character
 289     = arch_integer_type (gdbarch, TARGET_CHAR_BIT, 0, "character");
 290
 291   builtin_f_type->builtin_logical_s1
 292     = arch_boolean_type (gdbarch, TARGET_CHAR_BIT, 1, "logical*1");
 293
 294   builtin_f_type->builtin_integer_s2
 295     = arch_integer_type (gdbarch, gdbarch_short_bit (gdbarch), 0,
 296                          "integer*2");
 297
 298   builtin_f_type->builtin_logical_s2
 299     = arch_boolean_type (gdbarch, gdbarch_short_bit (gdbarch), 1,
 300                          "logical*2");
 301
 302   builtin_f_type->builtin_logical_s8
 303     = arch_boolean_type (gdbarch, gdbarch_long_long_bit (gdbarch), 1,
 304                          "logical*8");
 305
 306   builtin_f_type->builtin_integer
 307     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0,
 308                          "integer");
 309
 310   builtin_f_type->builtin_logical
 311     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1,
 312                          "logical*4");
 313
 314   builtin_f_type->builtin_real
 315     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch),
 316                        "real", NULL);
 317   builtin_f_type->builtin_real_s8
 318     = arch_float_type (gdbarch, gdbarch_double_bit (gdbarch),
 319                        "real*8", NULL);
 320   builtin_f_type->builtin_real_s16
 321     = arch_float_type (gdbarch, gdbarch_long_double_bit (gdbarch),
 322                        "real*16", NULL);
 323
 324   builtin_f_type->builtin_complex_s8
 325     = arch_complex_type (gdbarch, "complex*8",
 326                          builtin_f_type->builtin_real);
 327   builtin_f_type->builtin_complex_s16
 328     = arch_complex_type (gdbarch, "complex*16",
 329                          builtin_f_type->builtin_real_s8);
 330   builtin_f_type->builtin_complex_s32
 331     = arch_complex_type (gdbarch, "complex*32",
 332                          builtin_f_type->builtin_real_s16);
 333
 334   return builtin_f_type;
 335 }
 336
 337 static struct gdbarch_data *f_type_data;
 338
 339 const struct builtin_f_type *
 340 builtin_f_type (struct gdbarch *gdbarch)
 341 {
 342   return gdbarch_data (gdbarch, f_type_data);
 343 }
 344
 345 void
 346 _initialize_f_language (void)
 347 {
 348   f_type_data = gdbarch_data_register_post_init (build_fortran_types);
 349
 350   add_language (&f_language_defn);
 351 }
 352
 353 SAVED_F77_COMMON_PTR head_common_list = NULL;   /* Ptr to 1st saved COMMON  */
 354
 355 /* This routine finds the first encountred COMMON block named "name"
 356    that belongs to function funcname.  */
 357
 358 SAVED_F77_COMMON_PTR
 359 find_common_for_function (const char *name, const char *funcname)
 360 {
 361
 362   SAVED_F77_COMMON_PTR tmp;
 363
 364   tmp = head_common_list;
 365
 366   while (tmp != NULL)
 367     {
 368       if (strcmp (tmp->name, name) == 0
 369           && strcmp (tmp->owning_function, funcname) == 0)
 370         return (tmp);
 371       else
 372         tmp = tmp->next;
 373     }
 374   return (NULL);
 375 }