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