gdb/m2-lang.c

   1 /* Modula 2 language support routines for GDB, the GNU debugger.
   2
   3    Copyright (C) 1992-2022 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_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, {}, "_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 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 (value_type (arg1));
  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 (value_type (arg1) != type)
  91         arg1 = value_cast (type, arg1);
  92
  93       check_typedef (value_type (arg1));
  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 (type), VALUE_LVAL (arg1));
 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 languge.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   for (i = 0; i < length && things_printed < options->print_max; ++i)
 173     {
 174       /* Position of the character we are examining
 175          to see whether it is repeated.  */
 176       unsigned int rep1;
 177       /* Number of repetitions we have detected so far.  */
 178       unsigned int reps;
 179
 180       QUIT;
 181
 182       if (need_comma)
 183         {
 184           gdb_puts (", ", stream);
 185           need_comma = 0;
 186         }
 187
 188       rep1 = i + 1;
 189       reps = 1;
 190       while (rep1 < length && string[rep1] == string[i])
 191         {
 192           ++rep1;
 193           ++reps;
 194         }
 195
 196       if (reps > options->repeat_count_threshold)
 197         {
 198           if (in_quotes)
 199             {
 200               gdb_puts ("\", ", stream);
 201               in_quotes = 0;
 202             }
 203           printchar (string[i], elttype, stream);
 204           gdb_printf (stream, " <repeats %u times>", reps);
 205           i = rep1 - 1;
 206           things_printed += options->repeat_count_threshold;
 207           need_comma = 1;
 208         }
 209       else
 210         {
 211           if (!in_quotes)
 212             {
 213               gdb_puts ("\"", stream);
 214               in_quotes = 1;
 215             }
 216           emitchar (string[i], elttype, stream, '"');
 217           ++things_printed;
 218         }
 219     }
 220
 221   /* Terminate the quotes if necessary.  */
 222   if (in_quotes)
 223     gdb_puts ("\"", stream);
 224
 225   if (force_ellipses || i < length)
 226     gdb_puts ("...", stream);
 227 }
 228
 229 /* See language.h.  */
 230
 231 void
 232 m2_language::emitchar (int ch, struct type *chtype,
 233                        struct ui_file *stream, int quoter) const
 234 {
 235   ch &= 0xFF;                   /* Avoid sign bit follies.  */
 236
 237   if (PRINT_LITERAL_FORM (ch))
 238     {
 239       if (ch == '\\' || ch == quoter)
 240         gdb_puts ("\\", stream);
 241       gdb_printf (stream, "%c", ch);
 242     }
 243   else
 244     {
 245       switch (ch)
 246         {
 247         case '\n':
 248           gdb_puts ("\\n", stream);
 249           break;
 250         case '\b':
 251           gdb_puts ("\\b", stream);
 252           break;
 253         case '\t':
 254           gdb_puts ("\\t", stream);
 255           break;
 256         case '\f':
 257           gdb_puts ("\\f", stream);
 258           break;
 259         case '\r':
 260           gdb_puts ("\\r", stream);
 261           break;
 262         case '\033':
 263           gdb_puts ("\\e", stream);
 264           break;
 265         case '\007':
 266           gdb_puts ("\\a", stream);
 267           break;
 268         default:
 269           gdb_printf (stream, "\\%.3o", (unsigned int) ch);
 270           break;
 271         }
 272     }
 273 }
 274
 275 /* Called during architecture gdbarch initialisation to create language
 276    specific types.  */
 277
 278 static void *
 279 build_m2_types (struct gdbarch *gdbarch)
 280 {
 281   struct builtin_m2_type *builtin_m2_type
 282     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
 283
 284   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
 285   builtin_m2_type->builtin_int
 286     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
 287   builtin_m2_type->builtin_card
 288     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
 289   builtin_m2_type->builtin_real
 290     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
 291                        gdbarch_float_format (gdbarch));
 292   builtin_m2_type->builtin_char
 293     = arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
 294   builtin_m2_type->builtin_bool
 295     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
 296
 297   return builtin_m2_type;
 298 }
 299
 300 static struct gdbarch_data *m2_type_data;
 301
 302 const struct builtin_m2_type *
 303 builtin_m2_type (struct gdbarch *gdbarch)
 304 {
 305   return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
 306 }
 307
 308
 309 /* Initialization for Modula-2 */
 310
 311 void _initialize_m2_language ();
 312 void
 313 _initialize_m2_language ()
 314 {
 315   m2_type_data = gdbarch_data_register_post_init (build_m2_types);
 316 }