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 void m2_printchar (int, struct type *, struct ui_file *);
  33
  34 /* FIXME:  This is a copy of the same function from c-exp.y.  It should
  35    be replaced with a true Modula version.  */
  36
  37 static void
  38 m2_printchar (int c, struct type *type, struct ui_file *stream)
  39 {
  40   fputs_filtered ("'", stream);
  41   LA_EMIT_CHAR (c, type, stream, '\'');
  42   fputs_filtered ("'", stream);
  43 }
  44
  45 /* Print the character string STRING, printing at most LENGTH characters.
  46    Printing stops early if the number hits print_max; repeat counts
  47    are printed as appropriate.  Print ellipses at the end if we
  48    had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
  49    FIXME:  This is a copy of the same function from c-exp.y.  It should
  50    be replaced with a true Modula version.  */
  51
  52 static void
  53 m2_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
  54              unsigned int length, const char *encoding, int force_ellipses,
  55              const struct value_print_options *options)
  56 {
  57   unsigned int i;
  58   unsigned int things_printed = 0;
  59   int in_quotes = 0;
  60   int need_comma = 0;
  61
  62   if (length == 0)
  63     {
  64       fputs_filtered ("\"\"", gdb_stdout);
  65       return;
  66     }
  67
  68   for (i = 0; i < length && things_printed < options->print_max; ++i)
  69     {
  70       /* Position of the character we are examining
  71          to see whether it is repeated.  */
  72       unsigned int rep1;
  73       /* Number of repetitions we have detected so far.  */
  74       unsigned int reps;
  75
  76       QUIT;
  77
  78       if (need_comma)
  79         {
  80           fputs_filtered (", ", stream);
  81           need_comma = 0;
  82         }
  83
  84       rep1 = i + 1;
  85       reps = 1;
  86       while (rep1 < length && string[rep1] == string[i])
  87         {
  88           ++rep1;
  89           ++reps;
  90         }
  91
  92       if (reps > options->repeat_count_threshold)
  93         {
  94           if (in_quotes)
  95             {
  96               fputs_filtered ("\", ", stream);
  97               in_quotes = 0;
  98             }
  99           m2_printchar (string[i], type, stream);
 100           fprintf_filtered (stream, " <repeats %u times>", reps);
 101           i = rep1 - 1;
 102           things_printed += options->repeat_count_threshold;
 103           need_comma = 1;
 104         }
 105       else
 106         {
 107           if (!in_quotes)
 108             {
 109               fputs_filtered ("\"", stream);
 110               in_quotes = 1;
 111             }
 112           LA_EMIT_CHAR (string[i], type, stream, '"');
 113           ++things_printed;
 114         }
 115     }
 116
 117   /* Terminate the quotes if necessary.  */
 118   if (in_quotes)
 119     fputs_filtered ("\"", stream);
 120
 121   if (force_ellipses || i < length)
 122     fputs_filtered ("...", stream);
 123 }
 124
 125 /* Return true if TYPE is a string.  */
 126
 127 static bool
 128 m2_is_string_type_p (struct type *type)
 129 {
 130   type = check_typedef (type);
 131   if (type->code () == TYPE_CODE_ARRAY
 132       && TYPE_LENGTH (type) > 0
 133       && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
 134     {
 135       struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
 136
 137       if (TYPE_LENGTH (elttype) == 1
 138           && (elttype->code () == TYPE_CODE_INT
 139               || elttype->code () == TYPE_CODE_CHAR))
 140         return true;
 141     }
 142
 143   return false;
 144 }
 145
 146 static struct value *
 147 evaluate_subexp_modula2 (struct type *expect_type, struct expression *exp,
 148                          int *pos, enum noside noside)
 149 {
 150   enum exp_opcode op = exp->elts[*pos].opcode;
 151   struct value *arg1;
 152   struct value *arg2;
 153   struct type *type;
 154
 155   switch (op)
 156     {
 157     case UNOP_HIGH:
 158       (*pos)++;
 159       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 160
 161       if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
 162         return arg1;
 163       else
 164         {
 165           arg1 = coerce_ref (arg1);
 166           type = check_typedef (value_type (arg1));
 167
 168           if (m2_is_unbounded_array (type))
 169             {
 170               struct value *temp = arg1;
 171
 172               type = type->field (1).type ();
 173               /* i18n: Do not translate the "_m2_high" part!  */
 174               arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
 175                                        _("unbounded structure "
 176                                          "missing _m2_high field"));
 177
 178               if (value_type (arg1) != type)
 179                 arg1 = value_cast (type, arg1);
 180             }
 181         }
 182       return arg1;
 183
 184     case BINOP_SUBSCRIPT:
 185       (*pos)++;
 186       arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
 187       arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
 188       if (noside == EVAL_SKIP)
 189         goto nosideret;
 190       /* If the user attempts to subscript something that is not an
 191          array or pointer type (like a plain int variable for example),
 192          then report this as an error.  */
 193
 194       arg1 = coerce_ref (arg1);
 195       type = check_typedef (value_type (arg1));
 196
 197       if (m2_is_unbounded_array (type))
 198         {
 199           struct value *temp = arg1;
 200           type = type->field (0).type ();
 201           if (type == NULL || (type->code () != TYPE_CODE_PTR))
 202             {
 203               warning (_("internal error: unbounded "
 204                          "array structure is unknown"));
 205               return evaluate_subexp_standard (expect_type, exp, pos, noside);
 206             }
 207           /* i18n: Do not translate the "_m2_contents" part!  */
 208           arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
 209                                    _("unbounded structure "
 210                                      "missing _m2_contents field"));
 211
 212           if (value_type (arg1) != type)
 213             arg1 = value_cast (type, arg1);
 214
 215           check_typedef (value_type (arg1));
 216           return value_ind (value_ptradd (arg1, value_as_long (arg2)));
 217         }
 218       else
 219         if (type->code () != TYPE_CODE_ARRAY)
 220           {
 221             if (type->name ())
 222               error (_("cannot subscript something of type `%s'"),
 223                      type->name ());
 224             else
 225               error (_("cannot subscript requested type"));
 226           }
 227
 228       if (noside == EVAL_AVOID_SIDE_EFFECTS)
 229         return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
 230       else
 231         return value_subscript (arg1, value_as_long (arg2));
 232
 233     default:
 234       return evaluate_subexp_standard (expect_type, exp, pos, noside);
 235     }
 236
 237  nosideret:
 238   return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
 239 }
 240 \f
 241
 242 /* Table of operators and their precedences for printing expressions.  */
 243
 244 static const struct op_print m2_op_print_tab[] =
 245 {
 246   {"+", BINOP_ADD, PREC_ADD, 0},
 247   {"+", UNOP_PLUS, PREC_PREFIX, 0},
 248   {"-", BINOP_SUB, PREC_ADD, 0},
 249   {"-", UNOP_NEG, PREC_PREFIX, 0},
 250   {"*", BINOP_MUL, PREC_MUL, 0},
 251   {"/", BINOP_DIV, PREC_MUL, 0},
 252   {"DIV", BINOP_INTDIV, PREC_MUL, 0},
 253   {"MOD", BINOP_REM, PREC_MUL, 0},
 254   {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
 255   {"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
 256   {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
 257   {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
 258   {"=", BINOP_EQUAL, PREC_EQUAL, 0},
 259   {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
 260   {"<=", BINOP_LEQ, PREC_ORDER, 0},
 261   {">=", BINOP_GEQ, PREC_ORDER, 0},
 262   {">", BINOP_GTR, PREC_ORDER, 0},
 263   {"<", BINOP_LESS, PREC_ORDER, 0},
 264   {"^", UNOP_IND, PREC_PREFIX, 0},
 265   {"@", BINOP_REPEAT, PREC_REPEAT, 0},
 266   {"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
 267   {"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
 268   {"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
 269   {"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
 270   {"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
 271   {"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
 272   {"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
 273   {"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
 274   {"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
 275   {NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
 276 };
 277 \f
 278 /* The built-in types of Modula-2.  */
 279
 280 enum m2_primitive_types {
 281   m2_primitive_type_char,
 282   m2_primitive_type_int,
 283   m2_primitive_type_card,
 284   m2_primitive_type_real,
 285   m2_primitive_type_bool,
 286   nr_m2_primitive_types
 287 };
 288
 289 const struct exp_descriptor exp_descriptor_modula2 =
 290 {
 291   print_subexp_standard,
 292   operator_length_standard,
 293   operator_check_standard,
 294   op_name_standard,
 295   dump_subexp_body_standard,
 296   evaluate_subexp_modula2
 297 };
 298
 299 /* Constant data describing the M2 language.  */
 300
 301 extern const struct language_data m2_language_data =
 302 {
 303   "modula-2",
 304   "Modula-2",
 305   language_m2,
 306   range_check_on,
 307   case_sensitive_on,
 308   array_row_major,
 309   macro_expansion_no,
 310   NULL,
 311   &exp_descriptor_modula2,
 312   m2_printchar,                 /* Print character constant */
 313   m2_printstr,                  /* function to print string constant */
 314   m2_print_typedef,             /* Print a typedef using appropriate syntax */
 315   NULL,                         /* name_of_this */
 316   false,                        /* la_store_sym_names_in_linkage_form_p */
 317   m2_op_print_tab,              /* expression operators for printing */
 318   0,                            /* arrays are first-class (not c-style) */
 319   0,                            /* String lower bound */
 320   &default_varobj_ops,
 321   m2_is_string_type_p,
 322   "{...}"                       /* la_struct_too_deep_ellipsis */
 323 };
 324
 325 /* Class representing the M2 language.  */
 326
 327 class m2_language : public language_defn
 328 {
 329 public:
 330   m2_language ()
 331     : language_defn (language_m2, m2_language_data)
 332   { /* Nothing.  */ }
 333
 334   /* See language.h.  */
 335   void language_arch_info (struct gdbarch *gdbarch,
 336                            struct language_arch_info *lai) const override
 337   {
 338     const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
 339
 340     lai->string_char_type = builtin->builtin_char;
 341     lai->primitive_type_vector
 342       = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
 343                                 struct type *);
 344
 345     lai->primitive_type_vector [m2_primitive_type_char]
 346       = builtin->builtin_char;
 347     lai->primitive_type_vector [m2_primitive_type_int]
 348       = builtin->builtin_int;
 349     lai->primitive_type_vector [m2_primitive_type_card]
 350       = builtin->builtin_card;
 351     lai->primitive_type_vector [m2_primitive_type_real]
 352       = builtin->builtin_real;
 353     lai->primitive_type_vector [m2_primitive_type_bool]
 354       = builtin->builtin_bool;
 355
 356     lai->bool_type_symbol = "BOOLEAN";
 357     lai->bool_type_default = builtin->builtin_bool;
 358   }
 359
 360   /* See language.h.  */
 361
 362   void print_type (struct type *type, const char *varstring,
 363                    struct ui_file *stream, int show, int level,
 364                    const struct type_print_options *flags) const override
 365   {
 366     m2_print_type (type, varstring, stream, show, level, flags);
 367   }
 368
 369   /* See language.h.  */
 370
 371   void value_print_inner
 372         (struct value *val, struct ui_file *stream, int recurse,
 373          const struct value_print_options *options) const override
 374   {
 375     return m2_value_print_inner (val, stream, recurse, options);
 376   }
 377
 378   /* See language.h.  */
 379
 380   int parser (struct parser_state *ps) const override
 381   {
 382     return m2_parse (ps);
 383   }
 384
 385   /* See language.h.  */
 386
 387   void emitchar (int ch, struct type *chtype,
 388                  struct ui_file *stream, int quoter) const override
 389   {
 390     ch &= 0xFF;                 /* Avoid sign bit follies.  */
 391
 392     if (PRINT_LITERAL_FORM (ch))
 393       {
 394         if (ch == '\\' || ch == quoter)
 395           fputs_filtered ("\\", stream);
 396         fprintf_filtered (stream, "%c", ch);
 397       }
 398     else
 399       {
 400         switch (ch)
 401           {
 402           case '\n':
 403             fputs_filtered ("\\n", stream);
 404             break;
 405           case '\b':
 406             fputs_filtered ("\\b", stream);
 407             break;
 408           case '\t':
 409             fputs_filtered ("\\t", stream);
 410             break;
 411           case '\f':
 412             fputs_filtered ("\\f", stream);
 413             break;
 414           case '\r':
 415             fputs_filtered ("\\r", stream);
 416             break;
 417           case '\033':
 418             fputs_filtered ("\\e", stream);
 419             break;
 420           case '\007':
 421             fputs_filtered ("\\a", stream);
 422             break;
 423           default:
 424             fprintf_filtered (stream, "\\%.3o", (unsigned int) ch);
 425             break;
 426           }
 427       }
 428   }
 429 };
 430
 431 /* Single instance of the M2 language.  */
 432
 433 static m2_language m2_language_defn;
 434
 435 static void *
 436 build_m2_types (struct gdbarch *gdbarch)
 437 {
 438   struct builtin_m2_type *builtin_m2_type
 439     = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
 440
 441   /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
 442   builtin_m2_type->builtin_int
 443     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
 444   builtin_m2_type->builtin_card
 445     = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
 446   builtin_m2_type->builtin_real
 447     = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
 448                        gdbarch_float_format (gdbarch));
 449   builtin_m2_type->builtin_char
 450     = arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
 451   builtin_m2_type->builtin_bool
 452     = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
 453
 454   return builtin_m2_type;
 455 }
 456
 457 static struct gdbarch_data *m2_type_data;
 458
 459 const struct builtin_m2_type *
 460 builtin_m2_type (struct gdbarch *gdbarch)
 461 {
 462   return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
 463 }
 464
 465
 466 /* Initialization for Modula-2 */
 467
 468 void _initialize_m2_language ();
 469 void
 470 _initialize_m2_language ()
 471 {
 472   m2_type_data = gdbarch_data_register_post_init (build_m2_types);
 473 }