gdb/m2-lang.c

   1 /* Modula 2 language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1992-2021 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 /* A helper function for UNOP_HIGH.  */
  33
  34 static struct value *
  35 eval_op_m2_high (struct type *expect_type, struct expression *exp,
  36                  enum noside noside,
  37                  struct value *arg1)
  38 {
  39   if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
  40     return arg1;
  41   else
  42     {
  43       arg1 = coerce_ref (arg1);
  44       struct type *type = check_typedef (value_type (arg1));
  45
  46       if (m2_is_unbounded_array (type))
  47         {
  48           struct value *temp = arg1;
  49
  50           type = type->field (1).type ();
  51           /* i18n: Do not translate the "_m2_high" part!  */
  52           arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
  53                                    _("unbounded structure "
  54                                      "missing _m2_high field"));
  55
  56           if (value_type (arg1) != type)
  57             arg1 = value_cast (type, arg1);
  58         }
  59     }
  60   return arg1;
  61 }
  62
  63 /* A helper function for BINOP_SUBSCRIPT.  */
  64
  65 static struct value *
  66 eval_op_m2_subscript (struct type *expect_type, struct expression *exp,
  67                       enum noside noside,
  68                       struct value *arg1, struct value *arg2)
  69 {
  70   if (noside == EVAL_SKIP)
  71     return eval_skip_value (exp);
  72   /* If the user attempts to subscript something that is not an
  73      array or pointer type (like a plain int variable for example),
  74      then report this as an error.  */
  75
  76   arg1 = coerce_ref (arg1);
  77   struct type *type = check_typedef (value_type (arg1));
  78
  79   if (m2_is_unbounded_array (type))
  80     {
  81       struct value *temp = arg1;
  82       type = type->field (0).type ();
  83       if (type == NULL || (type->code () != TYPE_CODE_PTR))
  84         error (_("internal error: unbounded "
  85                  "array structure is unknown"));
  86       /* i18n: Do not translate the "_m2_contents" part!  */
  87       arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
  88                                _("unbounded structure "
  89                                  "missing _m2_contents field"));
  90
  91       if (value_type (arg1) != type)
  92         arg1 = value_cast (type, arg1);
  93
  94       check_typedef (value_type (arg1));
  95       return value_ind (value_ptradd (arg1, value_as_long (arg2)));
  96     }
  97   else
  98     if (type->code () != TYPE_CODE_ARRAY)
  99       {
 100         if (type->name ())
 101           error (_("cannot subscript something of type `%s'"),
 102                  type->name ());
 103         else
 104           error (_("cannot subscript requested type"));
 105       }
 106
 107   if (noside == EVAL_AVOID_SIDE_EFFECTS)
 108     return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
 109   else
 110     return value_subscript (arg1, value_as_long (arg2));
 111 }
 112
 113 static struct value *
 114 evaluate_subexp_modula2 (struct type *expect_type, struct expression *exp,
 115                          int *pos, enum noside noside)
 116 {
 117   enum exp_opcode op = exp->elts[*pos].opcode;
 118   struct value *arg1;
 119   struct value *arg2;
 120
 121   switch (op)
 122     {
 123     case UNOP_HIGH:
 124       (*pos)++;
 125       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 126       return eval_op_m2_high (expect_type, exp, noside, arg1);
 127
 128     case BINOP_SUBSCRIPT:
 129       (*pos)++;
 130       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 131       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 132       return eval_op_m2_subscript (expect_type, exp, noside, arg1, arg2);
 133
 134     default:
 135       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 136     }
 137 }
 138 \f
 139
 140 /* Table of operators and their precedences for printing expressions.  */
 141
 142 const struct op_print m2_language::op_print_tab[] =
 143 {
 144   {"+", BINOP_ADD, PREC_ADD, 0},
 145   {"+", UNOP_PLUS, PREC_PREFIX, 0},
 146   {"-", BINOP_SUB, PREC_ADD, 0},
 147   {"-", UNOP_NEG, PREC_PREFIX, 0},
 148   {"*", BINOP_MUL, PREC_MUL, 0},
 149   {"/", BINOP_DIV, PREC_MUL, 0},
 150   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
 151   {"MOD", BINOP_REM, PREC_MUL, 0},
 152   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 153   {"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 154   {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 155   {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 156   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 157   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 158   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 159   {">=", BINOP_GEQ, PREC_ORDER, 0},
 160   {">", BINOP_GTR, PREC_ORDER, 0},
 161   {"<", BINOP_LESS, PREC_ORDER, 0},
 162   {"^", UNOP_IND, PREC_PREFIX, 0},
 163   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 164   {"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
 165   {"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
 166   {"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
 167   {"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
 168   {"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
 169   {"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
 170   {"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
 171   {"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
 172   {"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
 173   {NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
 174 };
 175 \f
 176
 177 const struct exp_descriptor m2_language::exp_descriptor_modula2 =
 178 {
 179   print_subexp_standard,
 180   operator_length_standard,
 181   operator_check_standard,
 182   dump_subexp_body_standard,
 183   evaluate_subexp_modula2
 184 };
 185
 186 /* Single instance of the M2 language.  */
 187
 188 static m2_language m2_language_defn;
 189
 190 /* See language.h.  */
 191
 192 void
 193 m2_language::language_arch_info (struct gdbarch *gdbarch,
 194                                  struct language_arch_info *lai) const
 195 {
 196   const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
 197
 198   /* Helper function to allow shorter lines below.  */
 199   auto add  = [&] (struct type * t)
 200   {
 201     lai->add_primitive_type (t);
 202   };
 203
 204   add (builtin->builtin_char);
 205   add (builtin->builtin_int);
 206   add (builtin->builtin_card);
 207   add (builtin->builtin_real);
 208   add (builtin->builtin_bool);
 209
 210   lai->set_string_char_type (builtin->builtin_char);
 211   lai->set_bool_type (builtin->builtin_bool, "BOOLEAN");
 212 }
 213
 214 /* See languge.h.  */
 215
 216 void
 217 m2_language::printchar (int c, struct type *type,
 218                         struct ui_file *stream) const
 219 {
 220   fputs_filtered ("'", stream);
 221   emitchar (c, type, stream, '\'');
 222   fputs_filtered ("'", stream);
 223 }
 224
 225 /* See language.h.  */
 226
 227 void
 228 m2_language::printstr (struct ui_file *stream, struct type *elttype,
 229                         const gdb_byte *string, unsigned int length,
 230                         const char *encoding, int force_ellipses,
 231                         const struct value_print_options *options) const
 232 {
 233   unsigned int i;
 234   unsigned int things_printed = 0;
 235   int in_quotes = 0;
 236   int need_comma = 0;
 237
 238   if (length == 0)
 239     {
 240       fputs_filtered ("\"\"", gdb_stdout);
 241       return;
 242     }
 243
 244   for (i = 0; i < length && things_printed < options->print_max; ++i)
 245     {
 246       /* Position of the character we are examining
 247          to see whether it is repeated.  */
 248       unsigned int rep1;
 249       /* Number of repetitions we have detected so far.  */
 250       unsigned int reps;
 251
 252       QUIT;
 253
 254       if (need_comma)
 255         {
 256           fputs_filtered (", ", stream);
 257           need_comma = 0;
 258         }
 259
 260       rep1 = i + 1;
 261       reps = 1;
 262       while (rep1 < length && string[rep1] == string[i])
 263         {
 264           ++rep1;
 265           ++reps;
 266         }
 267
 268       if (reps > options->repeat_count_threshold)
 269         {
 270           if (in_quotes)
 271             {
 272               fputs_filtered ("\", ", stream);
 273               in_quotes = 0;
 274             }
 275           printchar (string[i], elttype, stream);
 276           fprintf_filtered (stream, " <repeats %u times>", reps);
 277           i = rep1 - 1;
 278           things_printed += options->repeat_count_threshold;
 279           need_comma = 1;
 280         }
 281       else
 282         {
 283           if (!in_quotes)
 284             {
 285               fputs_filtered ("\"", stream);
 286               in_quotes = 1;
 287             }
 288           emitchar (string[i], elttype, stream, '"');
 289           ++things_printed;
 290         }
 291     }
 292
 293   /* Terminate the quotes if necessary.  */
 294   if (in_quotes)
 295     fputs_filtered ("\"", stream);
 296
 297   if (force_ellipses || i < length)
 298     fputs_filtered ("...", stream);
 299 }
 300
 301 /* See language.h.  */
 302
 303 void
 304 m2_language::emitchar (int ch, struct type *chtype,
 305                        struct ui_file *stream, int quoter) const
 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 /* Called during architecture gdbarch initialisation to create language
 348    specific types.  */
 349
 350 static void *
 351 build_m2_types (struct gdbarch *gdbarch)
 352 {
 353   struct builtin_m2_type *builtin_m2_type
 354     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
 355
 356   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
 357   builtin_m2_type->builtin_int
 358     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
 359   builtin_m2_type->builtin_card
 360     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
 361   builtin_m2_type->builtin_real
 362     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
 363                        gdbarch_float_format (gdbarch));
 364   builtin_m2_type->builtin_char
 365     = arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
 366   builtin_m2_type->builtin_bool
 367     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
 368
 369   return builtin_m2_type;
 370 }
 371
 372 static struct gdbarch_data *m2_type_data;
 373
 374 const struct builtin_m2_type *
 375 builtin_m2_type (struct gdbarch *gdbarch)
 376 {
 377   return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
 378 }
 379
 380
 381 /* Initialization for Modula-2 */
 382
 383 void _initialize_m2_language ();
 384 void
 385 _initialize_m2_language ()
 386 {
 387   m2_type_data = gdbarch_data_register_post_init (build_m2_types);
 388 }