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, 2008 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 void m2_printchar (int, struct ui_file *);
  33 static void m2_emit_char (int, struct ui_file *, int);
  34
  35 /* Print the character C on STREAM as part of the contents of a literal
  36    string whose delimiter is QUOTER.  Note that that format for printing
  37    characters and strings is language specific.
  38    FIXME:  This is a copy of the same function from c-exp.y.  It should
  39    be replaced with a true Modula version.  */
  40
  41 static void
  42 m2_emit_char (int c, struct ui_file *stream, int quoter)
  43 {
  44
  45   c &= 0xFF;                    /* Avoid sign bit follies */
  46
  47   if (PRINT_LITERAL_FORM (c))
  48     {
  49       if (c == '\\' || c == quoter)
  50         {
  51           fputs_filtered ("\\", stream);
  52         }
  53       fprintf_filtered (stream, "%c", c);
  54     }
  55   else
  56     {
  57       switch (c)
  58         {
  59         case '\n':
  60           fputs_filtered ("\\n", stream);
  61           break;
  62         case '\b':
  63           fputs_filtered ("\\b", stream);
  64           break;
  65         case '\t':
  66           fputs_filtered ("\\t", stream);
  67           break;
  68         case '\f':
  69           fputs_filtered ("\\f", stream);
  70           break;
  71         case '\r':
  72           fputs_filtered ("\\r", stream);
  73           break;
  74         case '\033':
  75           fputs_filtered ("\\e", stream);
  76           break;
  77         case '\007':
  78           fputs_filtered ("\\a", stream);
  79           break;
  80         default:
  81           fprintf_filtered (stream, "\\%.3o", (unsigned int) c);
  82           break;
  83         }
  84     }
  85 }
  86
  87 /* FIXME:  This is a copy of the same function from c-exp.y.  It should
  88    be replaced with a true Modula version.  */
  89
  90 static void
  91 m2_printchar (int c, struct ui_file *stream)
  92 {
  93   fputs_filtered ("'", stream);
  94   LA_EMIT_CHAR (c, 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 Modula version.  */
 104
 105 static void
 106 m2_printstr (struct ui_file *stream, const gdb_byte *string,
 107              unsigned int length, int width, int force_ellipses)
 108 {
 109   unsigned int i;
 110   unsigned int things_printed = 0;
 111   int in_quotes = 0;
 112   int need_comma = 0;
 113
 114   if (length == 0)
 115     {
 116       fputs_filtered ("\"\"", gdb_stdout);
 117       return;
 118     }
 119
 120   for (i = 0; i < length && things_printed < print_max; ++i)
 121     {
 122       /* Position of the character we are examining
 123          to see whether it is repeated.  */
 124       unsigned int rep1;
 125       /* Number of repetitions we have detected so far.  */
 126       unsigned int reps;
 127
 128       QUIT;
 129
 130       if (need_comma)
 131         {
 132           fputs_filtered (", ", stream);
 133           need_comma = 0;
 134         }
 135
 136       rep1 = i + 1;
 137       reps = 1;
 138       while (rep1 < length && string[rep1] == string[i])
 139         {
 140           ++rep1;
 141           ++reps;
 142         }
 143
 144       if (reps > repeat_count_threshold)
 145         {
 146           if (in_quotes)
 147             {
 148               if (inspect_it)
 149                 fputs_filtered ("\\\", ", stream);
 150               else
 151                 fputs_filtered ("\", ", stream);
 152               in_quotes = 0;
 153             }
 154           m2_printchar (string[i], stream);
 155           fprintf_filtered (stream, " <repeats %u times>", reps);
 156           i = rep1 - 1;
 157           things_printed += repeat_count_threshold;
 158           need_comma = 1;
 159         }
 160       else
 161         {
 162           if (!in_quotes)
 163             {
 164               if (inspect_it)
 165                 fputs_filtered ("\\\"", stream);
 166               else
 167                 fputs_filtered ("\"", stream);
 168               in_quotes = 1;
 169             }
 170           LA_EMIT_CHAR (string[i], stream, '"');
 171           ++things_printed;
 172         }
 173     }
 174
 175   /* Terminate the quotes if necessary.  */
 176   if (in_quotes)
 177     {
 178       if (inspect_it)
 179         fputs_filtered ("\\\"", stream);
 180       else
 181         fputs_filtered ("\"", stream);
 182     }
 183
 184   if (force_ellipses || i < length)
 185     fputs_filtered ("...", stream);
 186 }
 187
 188 static struct value *
 189 evaluate_subexp_modula2 (struct type *expect_type, struct expression *exp,
 190                          int *pos, enum noside noside)
 191 {
 192   enum exp_opcode op = exp->elts[*pos].opcode;
 193   struct value *arg1;
 194   struct value *arg2;
 195   struct type *type;
 196   switch (op)
 197     {
 198     case UNOP_HIGH:
 199       (*pos)++;
 200       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 201
 202       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
 203         return arg1;
 204       else
 205         {
 206           arg1 = coerce_ref (arg1);
 207           type = check_typedef (value_type (arg1));
 208
 209           if (m2_is_unbounded_array (type))
 210             {
 211               struct value *temp = arg1;
 212               type = TYPE_FIELD_TYPE (type, 1);
 213               /* i18n: Do not translate the "_m2_high" part!  */
 214               arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
 215                                        _("unbounded structure "
 216                                          "missing _m2_high field"));
 217
 218               if (value_type (arg1) != type)
 219                 arg1 = value_cast (type, arg1);
 220             }
 221         }
 222       return arg1;
 223
 224     case BINOP_SUBSCRIPT:
 225       (*pos)++;
 226       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 227       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 228       if (noside == EVAL_SKIP)
 229         goto nosideret;
 230       /* If the user attempts to subscript something that is not an
 231          array or pointer type (like a plain int variable for example),
 232          then report this as an error.  */
 233
 234       arg1 = coerce_ref (arg1);
 235       type = check_typedef (value_type (arg1));
 236
 237       if (m2_is_unbounded_array (type))
 238         {
 239           struct value *temp = arg1;
 240           type = TYPE_FIELD_TYPE (type, 0);
 241           if (type == NULL || (TYPE_CODE (type) != TYPE_CODE_PTR)) {
 242             warning (_("internal error: unbounded array structure is unknown"));
 243             return evaluate_subexp_standard (expect_type, exp, pos, noside);
 244           }
 245           /* i18n: Do not translate the "_m2_contents" part!  */
 246           arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
 247                                    _("unbounded structure "
 248                                      "missing _m2_contents field"));
 249
 250           if (value_type (arg1) != type)
 251             arg1 = value_cast (type, arg1);
 252
 253           type = check_typedef (value_type (arg1));
 254           return value_ind (value_ptradd (arg1, arg2));
 255         }
 256       else
 257         if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
 258           {
 259             if (TYPE_NAME (type))
 260               error (_("cannot subscript something of type `%s'"),
 261                      TYPE_NAME (type));
 262             else
 263               error (_("cannot subscript requested type"));
 264           }
 265
 266       if (noside == EVAL_AVOID_SIDE_EFFECTS)
 267         return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
 268       else
 269         return value_subscript (arg1, arg2);
 270
 271     default:
 272       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 273     }
 274
 275  nosideret:
 276   return value_from_longest (builtin_type_long, (LONGEST) 1);
 277 }
 278 \f
 279
 280 /* Table of operators and their precedences for printing expressions.  */
 281
 282 static const struct op_print m2_op_print_tab[] =
 283 {
 284   {"+", BINOP_ADD, PREC_ADD, 0},
 285   {"+", UNOP_PLUS, PREC_PREFIX, 0},
 286   {"-", BINOP_SUB, PREC_ADD, 0},
 287   {"-", UNOP_NEG, PREC_PREFIX, 0},
 288   {"*", BINOP_MUL, PREC_MUL, 0},
 289   {"/", BINOP_DIV, PREC_MUL, 0},
 290   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
 291   {"MOD", BINOP_REM, PREC_MUL, 0},
 292   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 293   {"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 294   {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 295   {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 296   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 297   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 298   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 299   {">=", BINOP_GEQ, PREC_ORDER, 0},
 300   {">", BINOP_GTR, PREC_ORDER, 0},
 301   {"<", BINOP_LESS, PREC_ORDER, 0},
 302   {"^", UNOP_IND, PREC_PREFIX, 0},
 303   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 304   {"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
 305   {"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
 306   {"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
 307   {"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
 308   {"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
 309   {"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
 310   {"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
 311   {"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
 312   {"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
 313   {NULL, 0, 0, 0}
 314 };
 315 \f
 316 /* The built-in types of Modula-2.  */
 317
 318 enum m2_primitive_types {
 319   m2_primitive_type_char,
 320   m2_primitive_type_int,
 321   m2_primitive_type_card,
 322   m2_primitive_type_real,
 323   m2_primitive_type_bool,
 324   nr_m2_primitive_types
 325 };
 326
 327 static void
 328 m2_language_arch_info (struct gdbarch *gdbarch,
 329                        struct language_arch_info *lai)
 330 {
 331   const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
 332
 333   lai->string_char_type = builtin->builtin_char;
 334   lai->primitive_type_vector
 335     = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
 336                               struct type *);
 337
 338   lai->primitive_type_vector [m2_primitive_type_char]
 339     = builtin->builtin_char;
 340   lai->primitive_type_vector [m2_primitive_type_int]
 341     = builtin->builtin_int;
 342   lai->primitive_type_vector [m2_primitive_type_card]
 343     = builtin->builtin_card;
 344   lai->primitive_type_vector [m2_primitive_type_real]
 345     = builtin->builtin_real;
 346   lai->primitive_type_vector [m2_primitive_type_bool]
 347     = builtin->builtin_bool;
 348
 349   lai->bool_type_symbol = "BOOLEAN";
 350   lai->bool_type_default = builtin->builtin_bool;
 351 }
 352
 353 const struct exp_descriptor exp_descriptor_modula2 =
 354 {
 355   print_subexp_standard,
 356   operator_length_standard,
 357   op_name_standard,
 358   dump_subexp_body_standard,
 359   evaluate_subexp_modula2
 360 };
 361
 362 const struct language_defn m2_language_defn =
 363 {
 364   "modula-2",
 365   language_m2,
 366   range_check_on,
 367   type_check_on,
 368   case_sensitive_on,
 369   array_row_major,
 370   &exp_descriptor_modula2,
 371   m2_parse,                     /* parser */
 372   m2_error,                     /* parser error function */
 373   null_post_parser,
 374   m2_printchar,                 /* Print character constant */
 375   m2_printstr,                  /* function to print string constant */
 376   m2_emit_char,                 /* Function to print a single character */
 377   m2_print_type,                /* Print a type using appropriate syntax */
 378   m2_val_print,                 /* Print a value using appropriate syntax */
 379   c_value_print,                /* Print a top-level value */
 380   NULL,                         /* Language specific skip_trampoline */
 381   NULL,                         /* name_of_this */
 382   basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
 383   basic_lookup_transparent_type,/* lookup_transparent_type */
 384   NULL,                         /* Language specific symbol demangler */
 385   NULL,                         /* Language specific class_name_from_physname */
 386   m2_op_print_tab,              /* expression operators for printing */
 387   0,                            /* arrays are first-class (not c-style) */
 388   0,                            /* String lower bound */
 389   default_word_break_characters,
 390   default_make_symbol_completion_list,
 391   m2_language_arch_info,
 392   default_print_array_index,
 393   default_pass_by_reference,
 394   LANG_MAGIC
 395 };
 396
 397 static void *
 398 build_m2_types (struct gdbarch *gdbarch)
 399 {
 400   struct builtin_m2_type *builtin_m2_type
 401     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
 402
 403   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
 404   builtin_m2_type->builtin_int =
 405     init_type (TYPE_CODE_INT,
 406                gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
 407                0, "INTEGER", (struct objfile *) NULL);
 408   builtin_m2_type->builtin_card =
 409     init_type (TYPE_CODE_INT,
 410                gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
 411                TYPE_FLAG_UNSIGNED,
 412                "CARDINAL", (struct objfile *) NULL);
 413   builtin_m2_type->builtin_real =
 414     init_type (TYPE_CODE_FLT,
 415                gdbarch_float_bit (gdbarch) / TARGET_CHAR_BIT,
 416                0,
 417                "REAL", (struct objfile *) NULL);
 418   builtin_m2_type->builtin_char =
 419     init_type (TYPE_CODE_CHAR, TARGET_CHAR_BIT / TARGET_CHAR_BIT,
 420                TYPE_FLAG_UNSIGNED,
 421                "CHAR", (struct objfile *) NULL);
 422   builtin_m2_type->builtin_bool =
 423     init_type (TYPE_CODE_BOOL,
 424                gdbarch_int_bit (gdbarch) / TARGET_CHAR_BIT,
 425                TYPE_FLAG_UNSIGNED,
 426                "BOOLEAN", (struct objfile *) NULL);
 427
 428   return builtin_m2_type;
 429 }
 430
 431 static struct gdbarch_data *m2_type_data;
 432
 433 const struct builtin_m2_type *
 434 builtin_m2_type (struct gdbarch *gdbarch)
 435 {
 436   return gdbarch_data (gdbarch, m2_type_data);
 437 }
 438
 439
 440 /* Initialization for Modula-2 */
 441
 442 void
 443 _initialize_m2_language (void)
 444 {
 445   m2_type_data = gdbarch_data_register_post_init (build_m2_types);
 446
 447   add_language (&m2_language_defn);
 448 }