contrib/gdb-6/gdb/m2-lang.c

   1 /* Modula 2 language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 2000, 2002, 2003, 2004,
   4    2005, 2007 Free Software Foundation, Inc.
   5
   6    This file is part of GDB.
   7
   8    This program is free software; you can redistribute it and/or modify
   9    it under the terms of the GNU General Public License as published by
  10    the Free Software Foundation; either version 3 of the License, or
  11    (at your option) any later version.
  12
  13    This program is distributed in the hope that it will be useful,
  14    but WITHOUT ANY WARRANTY; without even the implied warranty of
  15    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16    GNU General Public License for more details.
  17
  18    You should have received a copy of the GNU General Public License
  19    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  20
  21 #include "defs.h"
  22 #include "symtab.h"
  23 #include "gdbtypes.h"
  24 #include "expression.h"
  25 #include "parser-defs.h"
  26 #include "language.h"
  27 #include "m2-lang.h"
  28 #include "c-lang.h"
  29 #include "valprint.h"
  30
  31 extern void _initialize_m2_language (void);
  32 static struct type *m2_create_fundamental_type (struct objfile *, int);
  33 static void m2_printchar (int, struct ui_file *);
  34 static void m2_emit_char (int, struct ui_file *, int);
  35
  36 /* Print the character C on STREAM as part of the contents of a literal
  37    string whose delimiter is QUOTER.  Note that that format for printing
  38    characters and strings is language specific.
  39    FIXME:  This is a copy of the same function from c-exp.y.  It should
  40    be replaced with a true Modula version.
  41  */
  42
  43 static void
  44 m2_emit_char (int c, struct ui_file *stream, int quoter)
  45 {
  46
  47   c &= 0xFF;                    /* Avoid sign bit follies */
  48
  49   if (PRINT_LITERAL_FORM (c))
  50     {
  51       if (c == '\\' || c == quoter)
  52         {
  53           fputs_filtered ("\\", stream);
  54         }
  55       fprintf_filtered (stream, "%c", c);
  56     }
  57   else
  58     {
  59       switch (c)
  60         {
  61         case '\n':
  62           fputs_filtered ("\\n", stream);
  63           break;
  64         case '\b':
  65           fputs_filtered ("\\b", stream);
  66           break;
  67         case '\t':
  68           fputs_filtered ("\\t", stream);
  69           break;
  70         case '\f':
  71           fputs_filtered ("\\f", stream);
  72           break;
  73         case '\r':
  74           fputs_filtered ("\\r", stream);
  75           break;
  76         case '\033':
  77           fputs_filtered ("\\e", stream);
  78           break;
  79         case '\007':
  80           fputs_filtered ("\\a", stream);
  81           break;
  82         default:
  83           fprintf_filtered (stream, "\\%.3o", (unsigned int) c);
  84           break;
  85         }
  86     }
  87 }
  88
  89 /* FIXME:  This is a copy of the same function from c-exp.y.  It should
  90    be replaced with a true Modula version. */
  91
  92 static void
  93 m2_printchar (int c, struct ui_file *stream)
  94 {
  95   fputs_filtered ("'", stream);
  96   LA_EMIT_CHAR (c, stream, '\'');
  97   fputs_filtered ("'", stream);
  98 }
  99
 100 /* Print the character string STRING, printing at most LENGTH characters.
 101    Printing stops early if the number hits print_max; repeat counts
 102    are printed as appropriate.  Print ellipses at the end if we
 103    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
 104    FIXME:  This is a copy of the same function from c-exp.y.  It should
 105    be replaced with a true Modula version. */
 106
 107 static void
 108 m2_printstr (struct ui_file *stream, const gdb_byte *string,
 109              unsigned int length, int width, int force_ellipses)
 110 {
 111   unsigned int i;
 112   unsigned int things_printed = 0;
 113   int in_quotes = 0;
 114   int need_comma = 0;
 115
 116   if (length == 0)
 117     {
 118       fputs_filtered ("\"\"", gdb_stdout);
 119       return;
 120     }
 121
 122   for (i = 0; i < length && things_printed < print_max; ++i)
 123     {
 124       /* Position of the character we are examining
 125          to see whether it is repeated.  */
 126       unsigned int rep1;
 127       /* Number of repetitions we have detected so far.  */
 128       unsigned int reps;
 129
 130       QUIT;
 131
 132       if (need_comma)
 133         {
 134           fputs_filtered (", ", stream);
 135           need_comma = 0;
 136         }
 137
 138       rep1 = i + 1;
 139       reps = 1;
 140       while (rep1 < length && string[rep1] == string[i])
 141         {
 142           ++rep1;
 143           ++reps;
 144         }
 145
 146       if (reps > repeat_count_threshold)
 147         {
 148           if (in_quotes)
 149             {
 150               if (inspect_it)
 151                 fputs_filtered ("\\\", ", stream);
 152               else
 153                 fputs_filtered ("\", ", stream);
 154               in_quotes = 0;
 155             }
 156           m2_printchar (string[i], stream);
 157           fprintf_filtered (stream, " <repeats %u times>", reps);
 158           i = rep1 - 1;
 159           things_printed += repeat_count_threshold;
 160           need_comma = 1;
 161         }
 162       else
 163         {
 164           if (!in_quotes)
 165             {
 166               if (inspect_it)
 167                 fputs_filtered ("\\\"", stream);
 168               else
 169                 fputs_filtered ("\"", stream);
 170               in_quotes = 1;
 171             }
 172           LA_EMIT_CHAR (string[i], stream, '"');
 173           ++things_printed;
 174         }
 175     }
 176
 177   /* Terminate the quotes if necessary.  */
 178   if (in_quotes)
 179     {
 180       if (inspect_it)
 181         fputs_filtered ("\\\"", stream);
 182       else
 183         fputs_filtered ("\"", stream);
 184     }
 185
 186   if (force_ellipses || i < length)
 187     fputs_filtered ("...", stream);
 188 }
 189
 190 /* FIXME:  This is a copy of c_create_fundamental_type(), before
 191    all the non-C types were stripped from it.  Needs to be fixed
 192    by an experienced Modula programmer. */
 193
 194 static struct type *
 195 m2_create_fundamental_type (struct objfile *objfile, int typeid)
 196 {
 197   struct type *type = NULL;
 198
 199   switch (typeid)
 200     {
 201     default:
 202       /* FIXME:  For now, if we are asked to produce a type not in this
 203          language, create the equivalent of a C integer type with the
 204          name "<?type?>".  When all the dust settles from the type
 205          reconstruction work, this should probably become an error. */
 206       type = init_type (TYPE_CODE_INT,
 207                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 208                         0, "<?type?>", objfile);
 209       warning (_("internal error: no Modula fundamental type %d"), typeid);
 210       break;
 211     case FT_VOID:
 212       type = init_type (TYPE_CODE_VOID,
 213                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 214                         0, "void", objfile);
 215       break;
 216     case FT_BOOLEAN:
 217       type = init_type (TYPE_CODE_BOOL,
 218                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 219                         TYPE_FLAG_UNSIGNED, "boolean", objfile);
 220       break;
 221     case FT_STRING:
 222       type = init_type (TYPE_CODE_STRING,
 223                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 224                         0, "string", objfile);
 225       break;
 226     case FT_CHAR:
 227       type = init_type (TYPE_CODE_INT,
 228                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 229                         0, "char", objfile);
 230       break;
 231     case FT_SIGNED_CHAR:
 232       type = init_type (TYPE_CODE_INT,
 233                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 234                         0, "signed char", objfile);
 235       break;
 236     case FT_UNSIGNED_CHAR:
 237       type = init_type (TYPE_CODE_INT,
 238                         TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 239                         TYPE_FLAG_UNSIGNED, "unsigned char", objfile);
 240       break;
 241     case FT_SHORT:
 242       type = init_type (TYPE_CODE_INT,
 243                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
 244                         0, "short", objfile);
 245       break;
 246     case FT_SIGNED_SHORT:
 247       type = init_type (TYPE_CODE_INT,
 248                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
 249                         0, "short", objfile);   /* FIXME-fnf */
 250       break;
 251     case FT_UNSIGNED_SHORT:
 252       type = init_type (TYPE_CODE_INT,
 253                         gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
 254                         TYPE_FLAG_UNSIGNED, "unsigned short", objfile);
 255       break;
 256     case FT_INTEGER:
 257       type = init_type (TYPE_CODE_INT,
 258                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 259                         0, "int", objfile);
 260       break;
 261     case FT_SIGNED_INTEGER:
 262       type = init_type (TYPE_CODE_INT,
 263                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 264                         0, "int", objfile);     /* FIXME -fnf */
 265       break;
 266     case FT_UNSIGNED_INTEGER:
 267       type = init_type (TYPE_CODE_INT,
 268                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 269                         TYPE_FLAG_UNSIGNED, "unsigned int", objfile);
 270       break;
 271     case FT_FIXED_DECIMAL:
 272       type = init_type (TYPE_CODE_INT,
 273                         gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 274                         0, "fixed decimal", objfile);
 275       break;
 276     case FT_LONG:
 277       type = init_type (TYPE_CODE_INT,
 278                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
 279                         0, "long", objfile);
 280       break;
 281     case FT_SIGNED_LONG:
 282       type = init_type (TYPE_CODE_INT,
 283                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
 284                         0, "long", objfile);    /* FIXME -fnf */
 285       break;
 286     case FT_UNSIGNED_LONG:
 287       type = init_type (TYPE_CODE_INT,
 288                         gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
 289                         TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
 290       break;
 291     case FT_LONG_LONG:
 292       type = init_type (TYPE_CODE_INT,
 293                         gdbarch_long_long_bit (current_gdbarch)
 294                           / TARGET_CHAR_BIT,
 295                         0, "long long", objfile);
 296       break;
 297     case FT_SIGNED_LONG_LONG:
 298       type = init_type (TYPE_CODE_INT,
 299                         gdbarch_long_long_bit (current_gdbarch)
 300                           / TARGET_CHAR_BIT,
 301                         0, "signed long long", objfile);
 302       break;
 303     case FT_UNSIGNED_LONG_LONG:
 304       type = init_type (TYPE_CODE_INT,
 305                         gdbarch_long_long_bit (current_gdbarch)
 306                           / TARGET_CHAR_BIT,
 307                         TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
 308       break;
 309     case FT_FLOAT:
 310       type = init_type (TYPE_CODE_FLT,
 311                         gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
 312                         0, "float", objfile);
 313       break;
 314     case FT_DBL_PREC_FLOAT:
 315       type = init_type (TYPE_CODE_FLT,
 316                         gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
 317                         0, "double", objfile);
 318       break;
 319     case FT_FLOAT_DECIMAL:
 320       type = init_type (TYPE_CODE_FLT,
 321                         gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
 322                         0, "floating decimal", objfile);
 323       break;
 324     case FT_EXT_PREC_FLOAT:
 325       type = init_type (TYPE_CODE_FLT,
 326                         gdbarch_long_double_bit (current_gdbarch)
 327                           / TARGET_CHAR_BIT,
 328                         0, "long double", objfile);
 329       break;
 330     case FT_COMPLEX:
 331       type = init_type (TYPE_CODE_COMPLEX,
 332                         2 * gdbarch_float_bit (current_gdbarch)
 333                           / TARGET_CHAR_BIT,
 334                         0, "complex", objfile);
 335       TYPE_TARGET_TYPE (type)
 336         = m2_create_fundamental_type (objfile, FT_FLOAT);
 337       break;
 338     case FT_DBL_PREC_COMPLEX:
 339       type = init_type (TYPE_CODE_COMPLEX,
 340                         2 * gdbarch_double_bit (current_gdbarch)
 341                           / TARGET_CHAR_BIT,
 342                         0, "double complex", objfile);
 343       TYPE_TARGET_TYPE (type)
 344         = m2_create_fundamental_type (objfile, FT_DBL_PREC_FLOAT);
 345       break;
 346     case FT_EXT_PREC_COMPLEX:
 347       type = init_type (TYPE_CODE_COMPLEX,
 348                         2 * gdbarch_long_double_bit (current_gdbarch)
 349                           / TARGET_CHAR_BIT,
 350                         0, "long double complex", objfile);
 351       TYPE_TARGET_TYPE (type)
 352         = m2_create_fundamental_type (objfile, FT_EXT_PREC_FLOAT);
 353       break;
 354     }
 355   return (type);
 356 }
 357 \f
 358
 359 /* Table of operators and their precedences for printing expressions.  */
 360
 361 static const struct op_print m2_op_print_tab[] =
 362 {
 363   {"+", BINOP_ADD, PREC_ADD, 0},
 364   {"+", UNOP_PLUS, PREC_PREFIX, 0},
 365   {"-", BINOP_SUB, PREC_ADD, 0},
 366   {"-", UNOP_NEG, PREC_PREFIX, 0},
 367   {"*", BINOP_MUL, PREC_MUL, 0},
 368   {"/", BINOP_DIV, PREC_MUL, 0},
 369   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
 370   {"MOD", BINOP_REM, PREC_MUL, 0},
 371   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 372   {"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 373   {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 374   {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 375   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 376   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 377   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 378   {">=", BINOP_GEQ, PREC_ORDER, 0},
 379   {">", BINOP_GTR, PREC_ORDER, 0},
 380   {"<", BINOP_LESS, PREC_ORDER, 0},
 381   {"^", UNOP_IND, PREC_PREFIX, 0},
 382   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 383   {"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
 384   {"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
 385   {"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
 386   {"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
 387   {"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
 388   {"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
 389   {"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
 390   {"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
 391   {"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
 392   {NULL, 0, 0, 0}
 393 };
 394 \f
 395 /* The built-in types of Modula-2.  */
 396
 397 enum m2_primitive_types {
 398   m2_primitive_type_char,
 399   m2_primitive_type_int,
 400   m2_primitive_type_card,
 401   m2_primitive_type_real,
 402   m2_primitive_type_bool,
 403   nr_m2_primitive_types
 404 };
 405
 406 static void
 407 m2_language_arch_info (struct gdbarch *gdbarch,
 408                        struct language_arch_info *lai)
 409 {
 410   const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
 411
 412   lai->string_char_type = builtin->builtin_char;
 413   lai->primitive_type_vector
 414     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
 415                               struct type *);
 416
 417   lai->primitive_type_vector [m2_primitive_type_char]
 418     = builtin->builtin_char;
 419   lai->primitive_type_vector [m2_primitive_type_int]
 420     = builtin->builtin_int;
 421   lai->primitive_type_vector [m2_primitive_type_card]
 422     = builtin->builtin_card;
 423   lai->primitive_type_vector [m2_primitive_type_real]
 424     = builtin->builtin_real;
 425   lai->primitive_type_vector [m2_primitive_type_bool]
 426     = builtin->builtin_bool;
 427 }
 428
 429 const struct language_defn m2_language_defn =
 430 {
 431   "modula-2",
 432   language_m2,
 433   NULL,
 434   range_check_on,
 435   type_check_on,
 436   case_sensitive_on,
 437   array_row_major,
 438   &exp_descriptor_standard,
 439   m2_parse,                     /* parser */
 440   m2_error,                     /* parser error function */
 441   null_post_parser,
 442   m2_printchar,                 /* Print character constant */
 443   m2_printstr,                  /* function to print string constant */
 444   m2_emit_char,                 /* Function to print a single character */
 445   m2_create_fundamental_type,   /* Create fundamental type in this language */
 446   m2_print_type,                /* Print a type using appropriate syntax */
 447   m2_val_print,                 /* Print a value using appropriate syntax */
 448   c_value_print,                /* Print a top-level value */
 449   NULL,                         /* Language specific skip_trampoline */
 450   value_of_this,                /* value_of_this */
 451   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
 452   basic_lookup_transparent_type,/* lookup_transparent_type */
 453   NULL,                         /* Language specific symbol demangler */
 454   NULL,                         /* Language specific class_name_from_physname */
 455   m2_op_print_tab,              /* expression operators for printing */
 456   0,                            /* arrays are first-class (not c-style) */
 457   0,                            /* String lower bound */
 458   NULL,
 459   default_word_break_characters,
 460   m2_language_arch_info,
 461   default_print_array_index,
 462   LANG_MAGIC
 463 };
 464
 465 static void *
 466 build_m2_types (struct gdbarch *gdbarch)
 467 {
 468   struct builtin_m2_type *builtin_m2_type
 469     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
 470
 471   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
 472   builtin_m2_type->builtin_int =
 473     init_type (TYPE_CODE_INT,
 474                gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 475                0, "INTEGER", (struct objfile *) NULL);
 476   builtin_m2_type->builtin_card =
 477     init_type (TYPE_CODE_INT,
 478                gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 479                TYPE_FLAG_UNSIGNED,
 480                "CARDINAL", (struct objfile *) NULL);
 481   builtin_m2_type->builtin_real =
 482     init_type (TYPE_CODE_FLT,
 483                gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
 484                0,
 485                "REAL", (struct objfile *) NULL);
 486   builtin_m2_type->builtin_char =
 487     init_type (TYPE_CODE_CHAR, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 488                TYPE_FLAG_UNSIGNED,
 489                "CHAR", (struct objfile *) NULL);
 490   builtin_m2_type->builtin_bool =
 491     init_type (TYPE_CODE_BOOL,
 492                gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
 493                TYPE_FLAG_UNSIGNED,
 494                "BOOLEAN", (struct objfile *) NULL);
 495
 496   return builtin_m2_type;
 497 }
 498
 499 static struct gdbarch_data *m2_type_data;
 500
 501 const struct builtin_m2_type *
 502 builtin_m2_type (struct gdbarch *gdbarch)
 503 {
 504   return gdbarch_data (gdbarch, m2_type_data);
 505 }
 506
 507
 508 /* Initialization for Modula-2 */
 509
 510 void
 511 _initialize_m2_language (void)
 512 {
 513   m2_type_data = gdbarch_data_register_post_init (build_m2_types);
 514
 515   add_language (&m2_language_defn);
 516 }