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