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