gdb/m2-lang.c

   1 /* Modula 2 language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1992-2024 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 "event-top.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_AVOID_SIDE_EFFECTS)
  41     return arg1;
  42   else
  43     {
  44       arg1 = coerce_ref (arg1);
  45       struct type *type = check_typedef (arg1->type ());
  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, {}, "_m2_high", NULL,
  54                                    _("unbounded structure "
  55                                      "missing _m2_high field"));
  56
  57           if (arg1->type () != 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 the user attempts to subscript something that is not an
  72      array or pointer type (like a plain int variable for example),
  73      then report this as an error.  */
  74
  75   arg1 = coerce_ref (arg1);
  76   struct type *type = check_typedef (arg1->type ());
  77
  78   if (m2_is_unbounded_array (type))
  79     {
  80       struct value *temp = arg1;
  81       type = type->field (0).type ();
  82       if (type == NULL || (type->code () != TYPE_CODE_PTR))
  83         error (_("internal error: unbounded "
  84                  "array structure is unknown"));
  85       /* i18n: Do not translate the "_m2_contents" part!  */
  86       arg1 = value_struct_elt (&temp, {}, "_m2_contents", NULL,
  87                                _("unbounded structure "
  88                                  "missing _m2_contents field"));
  89
  90       if (arg1->type () != type)
  91         arg1 = value_cast (type, arg1);
  92
  93       check_typedef (arg1->type ());
  94       return value_ind (value_ptradd (arg1, value_as_long (arg2)));
  95     }
  96   else
  97     if (type->code () != TYPE_CODE_ARRAY)
  98       {
  99         if (type->name ())
 100           error (_("cannot subscript something of type `%s'"),
 101                  type->name ());
 102         else
 103           error (_("cannot subscript requested type"));
 104       }
 105
 106   if (noside == EVAL_AVOID_SIDE_EFFECTS)
 107     return value::zero (type->target_type (), arg1->lval ());
 108   else
 109     return value_subscript (arg1, value_as_long (arg2));
 110 }
 111
 112 \f
 113
 114 /* Single instance of the M2 language.  */
 115
 116 static m2_language m2_language_defn;
 117
 118 /* See language.h.  */
 119
 120 void
 121 m2_language::language_arch_info (struct gdbarch *gdbarch,
 122                                  struct language_arch_info *lai) const
 123 {
 124   const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
 125
 126   /* Helper function to allow shorter lines below.  */
 127   auto add  = [&] (struct type * t)
 128   {
 129     lai->add_primitive_type (t);
 130   };
 131
 132   add (builtin->builtin_char);
 133   add (builtin->builtin_int);
 134   add (builtin->builtin_card);
 135   add (builtin->builtin_real);
 136   add (builtin->builtin_bool);
 137
 138   lai->set_string_char_type (builtin->builtin_char);
 139   lai->set_bool_type (builtin->builtin_bool, "BOOLEAN");
 140 }
 141
 142 /* See language.h.  */
 143
 144 void
 145 m2_language::printchar (int c, struct type *type,
 146                         struct ui_file *stream) const
 147 {
 148   gdb_puts ("'", stream);
 149   emitchar (c, type, stream, '\'');
 150   gdb_puts ("'", stream);
 151 }
 152
 153 /* See language.h.  */
 154
 155 void
 156 m2_language::printstr (struct ui_file *stream, struct type *elttype,
 157                         const gdb_byte *string, unsigned int length,
 158                         const char *encoding, int force_ellipses,
 159                         const struct value_print_options *options) const
 160 {
 161   unsigned int i;
 162   unsigned int things_printed = 0;
 163   int in_quotes = 0;
 164   int need_comma = 0;
 165
 166   if (length == 0)
 167     {
 168       gdb_puts ("\"\"");
 169       return;
 170     }
 171
 172   unsigned int print_max_chars = get_print_max_chars (options);
 173   for (i = 0; i < length && things_printed < print_max_chars; ++i)
 174     {
 175       /* Position of the character we are examining
 176          to see whether it is repeated.  */
 177       unsigned int rep1;
 178       /* Number of repetitions we have detected so far.  */
 179       unsigned int reps;
 180
 181       QUIT;
 182
 183       if (need_comma)
 184         {
 185           gdb_puts (", ", stream);
 186           need_comma = 0;
 187         }
 188
 189       rep1 = i + 1;
 190       reps = 1;
 191       while (rep1 < length && string[rep1] == string[i])
 192         {
 193           ++rep1;
 194           ++reps;
 195         }
 196
 197       if (reps > options->repeat_count_threshold)
 198         {
 199           if (in_quotes)
 200             {
 201               gdb_puts ("\", ", stream);
 202               in_quotes = 0;
 203             }
 204           printchar (string[i], elttype, stream);
 205           gdb_printf (stream, " <repeats %u times>", reps);
 206           i = rep1 - 1;
 207           things_printed += options->repeat_count_threshold;
 208           need_comma = 1;
 209         }
 210       else
 211         {
 212           if (!in_quotes)
 213             {
 214               gdb_puts ("\"", stream);
 215               in_quotes = 1;
 216             }
 217           emitchar (string[i], elttype, stream, '"');
 218           ++things_printed;
 219         }
 220     }
 221
 222   /* Terminate the quotes if necessary.  */
 223   if (in_quotes)
 224     gdb_puts ("\"", stream);
 225
 226   if (force_ellipses || i < length)
 227     gdb_puts ("...", stream);
 228 }
 229
 230 /* See language.h.  */
 231
 232 void
 233 m2_language::emitchar (int ch, struct type *chtype,
 234                        struct ui_file *stream, int quoter) const
 235 {
 236   ch &= 0xFF;                   /* Avoid sign bit follies.  */
 237
 238   if (PRINT_LITERAL_FORM (ch))
 239     {
 240       if (ch == '\\' || ch == quoter)
 241         gdb_puts ("\\", stream);
 242       gdb_printf (stream, "%c", ch);
 243     }
 244   else
 245     {
 246       switch (ch)
 247         {
 248         case '\n':
 249           gdb_puts ("\\n", stream);
 250           break;
 251         case '\b':
 252           gdb_puts ("\\b", stream);
 253           break;
 254         case '\t':
 255           gdb_puts ("\\t", stream);
 256           break;
 257         case '\f':
 258           gdb_puts ("\\f", stream);
 259           break;
 260         case '\r':
 261           gdb_puts ("\\r", stream);
 262           break;
 263         case '\033':
 264           gdb_puts ("\\e", stream);
 265           break;
 266         case '\007':
 267           gdb_puts ("\\a", stream);
 268           break;
 269         default:
 270           gdb_printf (stream, "\\%.3o", (unsigned int) ch);
 271           break;
 272         }
 273     }
 274 }
 275
 276 /* Called during architecture gdbarch initialisation to create language
 277    specific types.  */
 278
 279 static struct builtin_m2_type *
 280 build_m2_types (struct gdbarch *gdbarch)
 281 {
 282   struct builtin_m2_type *builtin_m2_type = new struct builtin_m2_type;
 283
 284   type_allocator alloc (gdbarch);
 285
 286   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
 287   builtin_m2_type->builtin_int
 288     = init_integer_type (alloc, gdbarch_int_bit (gdbarch), 0, "INTEGER");
 289   builtin_m2_type->builtin_card
 290     = init_integer_type (alloc, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
 291   builtin_m2_type->builtin_real
 292     = init_float_type (alloc, gdbarch_float_bit (gdbarch), "REAL",
 293                        gdbarch_float_format (gdbarch));
 294   builtin_m2_type->builtin_char
 295     = init_character_type (alloc, TARGET_CHAR_BIT, 1, "CHAR");
 296   builtin_m2_type->builtin_bool
 297     = init_boolean_type (alloc, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
 298
 299   return builtin_m2_type;
 300 }
 301
 302 static const registry<gdbarch>::key<struct builtin_m2_type> m2_type_data;
 303
 304 const struct builtin_m2_type *
 305 builtin_m2_type (struct gdbarch *gdbarch)
 306 {
 307   struct builtin_m2_type *result = m2_type_data.get (gdbarch);
 308   if (result == nullptr)
 309     {
 310       result = build_m2_types (gdbarch);
 311       m2_type_data.set (gdbarch, result);
 312     }
 313
 314   return result;
 315 }