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