gdb/m2-lang.c

   1 /* Modula 2 language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1992-2020 Free Software Foundation, Inc.
   4
   5    This file is part of GDB.
   6
   7    This program is free software; you can redistribute it and/or modify
   8    it under the terms of the GNU General Public License as published by
   9    the Free Software Foundation; either version 3 of the License, or
  10    (at your option) any later version.
  11
  12    This program is distributed in the hope that it will be useful,
  13    but WITHOUT ANY WARRANTY; without even the implied warranty of
  14    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15    GNU General Public License for more details.
  16
  17    You should have received a copy of the GNU General Public License
  18    along with this program.  If not, see <http://www.gnu.org/licenses/>.  */
  19
  20 #include "defs.h"
  21 #include "symtab.h"
  22 #include "gdbtypes.h"
  23 #include "expression.h"
  24 #include "parser-defs.h"
  25 #include "language.h"
  26 #include "varobj.h"
  27 #include "m2-lang.h"
  28 #include "c-lang.h"
  29 #include "valprint.h"
  30 #include "gdbarch.h"
  31
  32 static void m2_printchar (int, struct type *, struct ui_file *);
  33
  34 /* FIXME:  This is a copy of the same function from c-exp.y.  It should
  35    be replaced with a true Modula version.  */
  36
  37 static void
  38 m2_printchar (int c, struct type *type, struct ui_file *stream)
  39 {
  40   fputs_filtered ("'", stream);
  41   LA_EMIT_CHAR (c, type, stream, '\'');
  42   fputs_filtered ("'", stream);
  43 }
  44
  45 static struct value *
  46 evaluate_subexp_modula2 (struct type *expect_type, struct expression *exp,
  47                          int *pos, enum noside noside)
  48 {
  49   enum exp_opcode op = exp->elts[*pos].opcode;
  50   struct value *arg1;
  51   struct value *arg2;
  52   struct type *type;
  53
  54   switch (op)
  55     {
  56     case UNOP_HIGH:
  57       (*pos)++;
  58       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
  59
  60       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
  61         return arg1;
  62       else
  63         {
  64           arg1 = coerce_ref (arg1);
  65           type = check_typedef (value_type (arg1));
  66
  67           if (m2_is_unbounded_array (type))
  68             {
  69               struct value *temp = arg1;
  70
  71               type = type->field (1).type ();
  72               /* i18n: Do not translate the "_m2_high" part!  */
  73               arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
  74                                        _("unbounded structure "
  75                                          "missing _m2_high field"));
  76
  77               if (value_type (arg1) != type)
  78                 arg1 = value_cast (type, arg1);
  79             }
  80         }
  81       return arg1;
  82
  83     case BINOP_SUBSCRIPT:
  84       (*pos)++;
  85       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
  86       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
  87       if (noside == EVAL_SKIP)
  88         goto nosideret;
  89       /* If the user attempts to subscript something that is not an
  90          array or pointer type (like a plain int variable for example),
  91          then report this as an error.  */
  92
  93       arg1 = coerce_ref (arg1);
  94       type = check_typedef (value_type (arg1));
  95
  96       if (m2_is_unbounded_array (type))
  97         {
  98           struct value *temp = arg1;
  99           type = type->field (0).type ();
 100           if (type == NULL || (type->code () != TYPE_CODE_PTR))
 101             {
 102               warning (_("internal error: unbounded "
 103                          "array structure is unknown"));
 104               return evaluate_subexp_standard (expect_type, exp, pos, noside);
 105             }
 106           /* i18n: Do not translate the "_m2_contents" part!  */
 107           arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
 108                                    _("unbounded structure "
 109                                      "missing _m2_contents field"));
 110
 111           if (value_type (arg1) != type)
 112             arg1 = value_cast (type, arg1);
 113
 114           check_typedef (value_type (arg1));
 115           return value_ind (value_ptradd (arg1, value_as_long (arg2)));
 116         }
 117       else
 118         if (type->code () != TYPE_CODE_ARRAY)
 119           {
 120             if (type->name ())
 121               error (_("cannot subscript something of type `%s'"),
 122                      type->name ());
 123             else
 124               error (_("cannot subscript requested type"));
 125           }
 126
 127       if (noside == EVAL_AVOID_SIDE_EFFECTS)
 128         return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
 129       else
 130         return value_subscript (arg1, value_as_long (arg2));
 131
 132     default:
 133       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 134     }
 135
 136  nosideret:
 137   return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
 138 }
 139 \f
 140
 141 /* Table of operators and their precedences for printing expressions.  */
 142
 143 static const struct op_print m2_op_print_tab[] =
 144 {
 145   {"+", BINOP_ADD, PREC_ADD, 0},
 146   {"+", UNOP_PLUS, PREC_PREFIX, 0},
 147   {"-", BINOP_SUB, PREC_ADD, 0},
 148   {"-", UNOP_NEG, PREC_PREFIX, 0},
 149   {"*", BINOP_MUL, PREC_MUL, 0},
 150   {"/", BINOP_DIV, PREC_MUL, 0},
 151   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
 152   {"MOD", BINOP_REM, PREC_MUL, 0},
 153   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 154   {"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 155   {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 156   {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 157   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 158   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 159   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 160   {">=", BINOP_GEQ, PREC_ORDER, 0},
 161   {">", BINOP_GTR, PREC_ORDER, 0},
 162   {"<", BINOP_LESS, PREC_ORDER, 0},
 163   {"^", UNOP_IND, PREC_PREFIX, 0},
 164   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 165   {"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
 166   {"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
 167   {"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
 168   {"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
 169   {"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
 170   {"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
 171   {"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
 172   {"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
 173   {"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
 174   {NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
 175 };
 176 \f
 177 /* The built-in types of Modula-2.  */
 178
 179 enum m2_primitive_types {
 180   m2_primitive_type_char,
 181   m2_primitive_type_int,
 182   m2_primitive_type_card,
 183   m2_primitive_type_real,
 184   m2_primitive_type_bool,
 185   nr_m2_primitive_types
 186 };
 187
 188 const struct exp_descriptor exp_descriptor_modula2 =
 189 {
 190   print_subexp_standard,
 191   operator_length_standard,
 192   operator_check_standard,
 193   op_name_standard,
 194   dump_subexp_body_standard,
 195   evaluate_subexp_modula2
 196 };
 197
 198 /* Constant data describing the M2 language.  */
 199
 200 extern const struct language_data m2_language_data =
 201 {
 202 };
 203
 204 /* Class representing the M2 language.  */
 205
 206 class m2_language : public language_defn
 207 {
 208 public:
 209   m2_language ()
 210     : language_defn (language_m2, m2_language_data)
 211   { /* Nothing.  */ }
 212
 213   /* See language.h.  */
 214
 215   const char *name () const override
 216   { return "modula-2"; }
 217
 218   /* See language.h.  */
 219
 220   const char *natural_name () const override
 221   { return "Modula-2"; }
 222
 223   /* See language.h.  */
 224   void language_arch_info (struct gdbarch *gdbarch,
 225                            struct language_arch_info *lai) const override
 226   {
 227     const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
 228
 229     lai->string_char_type = builtin->builtin_char;
 230     lai->primitive_type_vector
 231       = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
 232                                 struct type *);
 233
 234     lai->primitive_type_vector [m2_primitive_type_char]
 235       = builtin->builtin_char;
 236     lai->primitive_type_vector [m2_primitive_type_int]
 237       = builtin->builtin_int;
 238     lai->primitive_type_vector [m2_primitive_type_card]
 239       = builtin->builtin_card;
 240     lai->primitive_type_vector [m2_primitive_type_real]
 241       = builtin->builtin_real;
 242     lai->primitive_type_vector [m2_primitive_type_bool]
 243       = builtin->builtin_bool;
 244
 245     lai->bool_type_symbol = "BOOLEAN";
 246     lai->bool_type_default = builtin->builtin_bool;
 247   }
 248
 249   /* See language.h.  */
 250
 251   void print_type (struct type *type, const char *varstring,
 252                    struct ui_file *stream, int show, int level,
 253                    const struct type_print_options *flags) const override
 254   {
 255     m2_print_type (type, varstring, stream, show, level, flags);
 256   }
 257
 258   /* See language.h.  */
 259
 260   void value_print_inner
 261         (struct value *val, struct ui_file *stream, int recurse,
 262          const struct value_print_options *options) const override
 263   {
 264     return m2_value_print_inner (val, stream, recurse, options);
 265   }
 266
 267   /* See language.h.  */
 268
 269   int parser (struct parser_state *ps) const override
 270   {
 271     return m2_parse (ps);
 272   }
 273
 274   /* See language.h.  */
 275
 276   void emitchar (int ch, struct type *chtype,
 277                  struct ui_file *stream, int quoter) const override
 278   {
 279     ch &= 0xFF;                 /* Avoid sign bit follies.  */
 280
 281     if (PRINT_LITERAL_FORM (ch))
 282       {
 283         if (ch == '\\' || ch == quoter)
 284           fputs_filtered ("\\", stream);
 285         fprintf_filtered (stream, "%c", ch);
 286       }
 287     else
 288       {
 289         switch (ch)
 290           {
 291           case '\n':
 292             fputs_filtered ("\\n", stream);
 293             break;
 294           case '\b':
 295             fputs_filtered ("\\b", stream);
 296             break;
 297           case '\t':
 298             fputs_filtered ("\\t", stream);
 299             break;
 300           case '\f':
 301             fputs_filtered ("\\f", stream);
 302             break;
 303           case '\r':
 304             fputs_filtered ("\\r", stream);
 305             break;
 306           case '\033':
 307             fputs_filtered ("\\e", stream);
 308             break;
 309           case '\007':
 310             fputs_filtered ("\\a", stream);
 311             break;
 312           default:
 313             fprintf_filtered (stream, "\\%.3o", (unsigned int) ch);
 314             break;
 315           }
 316       }
 317   }
 318
 319   /* See language.h.  */
 320
 321   void printchar (int ch, struct type *chtype,
 322                   struct ui_file *stream) const override
 323   {
 324     m2_printchar (ch, chtype, stream);
 325   }
 326
 327   /* See language.h.  */
 328
 329   void printstr (struct ui_file *stream, struct type *elttype,
 330                  const gdb_byte *string, unsigned int length,
 331                  const char *encoding, int force_ellipses,
 332                  const struct value_print_options *options) const override
 333   {
 334     unsigned int i;
 335     unsigned int things_printed = 0;
 336     int in_quotes = 0;
 337     int need_comma = 0;
 338
 339     if (length == 0)
 340       {
 341         fputs_filtered ("\"\"", gdb_stdout);
 342         return;
 343       }
 344
 345     for (i = 0; i < length && things_printed < options->print_max; ++i)
 346       {
 347         /* Position of the character we are examining
 348            to see whether it is repeated.  */
 349         unsigned int rep1;
 350         /* Number of repetitions we have detected so far.  */
 351         unsigned int reps;
 352
 353         QUIT;
 354
 355         if (need_comma)
 356           {
 357             fputs_filtered (", ", stream);
 358             need_comma = 0;
 359           }
 360
 361         rep1 = i + 1;
 362         reps = 1;
 363         while (rep1 < length && string[rep1] == string[i])
 364           {
 365             ++rep1;
 366             ++reps;
 367           }
 368
 369         if (reps > options->repeat_count_threshold)
 370           {
 371             if (in_quotes)
 372               {
 373                 fputs_filtered ("\", ", stream);
 374                 in_quotes = 0;
 375               }
 376             m2_printchar (string[i], elttype, stream);
 377             fprintf_filtered (stream, " <repeats %u times>", reps);
 378             i = rep1 - 1;
 379             things_printed += options->repeat_count_threshold;
 380             need_comma = 1;
 381           }
 382         else
 383           {
 384             if (!in_quotes)
 385               {
 386                 fputs_filtered ("\"", stream);
 387                 in_quotes = 1;
 388               }
 389             LA_EMIT_CHAR (string[i], elttype, stream, '"');
 390             ++things_printed;
 391           }
 392       }
 393
 394     /* Terminate the quotes if necessary.  */
 395     if (in_quotes)
 396       fputs_filtered ("\"", stream);
 397
 398     if (force_ellipses || i < length)
 399       fputs_filtered ("...", stream);
 400   }
 401
 402   /* See language.h.  */
 403
 404   void print_typedef (struct type *type, struct symbol *new_symbol,
 405                       struct ui_file *stream) const override
 406   {
 407     m2_print_typedef (type, new_symbol, stream);
 408   }
 409
 410   /* See language.h.  */
 411
 412   bool is_string_type_p (struct type *type) const override
 413   {
 414     type = check_typedef (type);
 415     if (type->code () == TYPE_CODE_ARRAY
 416         && TYPE_LENGTH (type) > 0
 417         && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
 418       {
 419         struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
 420
 421         if (TYPE_LENGTH (elttype) == 1
 422             && (elttype->code () == TYPE_CODE_INT
 423                 || elttype->code () == TYPE_CODE_CHAR))
 424           return true;
 425       }
 426
 427     return false;
 428   }
 429
 430   /* See language.h.  */
 431
 432   bool c_style_arrays_p () const override
 433   { return false; }
 434
 435   /* See language.h.  Despite not having C-style arrays, Modula-2 uses 0
 436      for its string lower bounds.  */
 437
 438   char string_lower_bound () const override
 439   { return 0; }
 440
 441   /* See language.h.  */
 442
 443   bool range_checking_on_by_default () const override
 444   { return true; }
 445
 446   /* See language.h.  */
 447
 448   const struct exp_descriptor *expression_ops () const override
 449   { return &exp_descriptor_modula2; }
 450
 451   /* See language.h.  */
 452
 453   const struct op_print *opcode_print_table () const override
 454   { return m2_op_print_tab; }
 455 };
 456
 457 /* Single instance of the M2 language.  */
 458
 459 static m2_language m2_language_defn;
 460
 461 static void *
 462 build_m2_types (struct gdbarch *gdbarch)
 463 {
 464   struct builtin_m2_type *builtin_m2_type
 465     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
 466
 467   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
 468   builtin_m2_type->builtin_int
 469     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
 470   builtin_m2_type->builtin_card
 471     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
 472   builtin_m2_type->builtin_real
 473     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
 474                        gdbarch_float_format (gdbarch));
 475   builtin_m2_type->builtin_char
 476     = arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
 477   builtin_m2_type->builtin_bool
 478     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
 479
 480   return builtin_m2_type;
 481 }
 482
 483 static struct gdbarch_data *m2_type_data;
 484
 485 const struct builtin_m2_type *
 486 builtin_m2_type (struct gdbarch *gdbarch)
 487 {
 488   return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
 489 }
 490
 491
 492 /* Initialization for Modula-2 */
 493
 494 void _initialize_m2_language ();
 495 void
 496 _initialize_m2_language ()
 497 {
 498   m2_type_data = gdbarch_data_register_post_init (build_m2_types);
 499 }