gdb/m2-lang.c

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