1 /* Pascal language support routines for GDB, the GNU debugger. 2 3 Copyright (C) 2000-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 /* This file is derived from c-lang.c */ 21 22 #include "defs.h" 23 #include "symtab.h" 24 #include "gdbtypes.h" 25 #include "expression.h" 26 #include "parser-defs.h" 27 #include "language.h" 28 #include "varobj.h" 29 #include "p-lang.h" 30 #include "valprint.h" 31 #include "value.h" 32 #include <ctype.h> 33 #include "c-lang.h" 34 #include "gdbarch.h" 35 #include "cli/cli-style.h" 36 37 /* All GPC versions until now (2007-09-27) also define a symbol called 38 '_p_initialize'. Check for the presence of this symbol first. */ 39 static const char GPC_P_INITIALIZE[] = "_p_initialize"; 40 41 /* The name of the symbol that GPC uses as the name of the main 42 procedure (since version 20050212). */ 43 static const char GPC_MAIN_PROGRAM_NAME_1[] = "_p__M0_main_program"; 44 45 /* Older versions of GPC (versions older than 20050212) were using 46 a different name for the main procedure. */ 47 static const char GPC_MAIN_PROGRAM_NAME_2[] = "pascal_main_program"; 48 49 /* Function returning the special symbol name used 50 by GPC for the main procedure in the main program 51 if it is found in minimal symbol list. 52 This function tries to find minimal symbols generated by GPC 53 so that it finds the even if the program was compiled 54 without debugging information. 55 According to information supplied by Waldeck Hebisch, 56 this should work for all versions posterior to June 2000. */ 57 58 const char * 59 pascal_main_name (void) 60 { 61 struct bound_minimal_symbol msym; 62 63 msym = lookup_minimal_symbol (GPC_P_INITIALIZE, NULL, NULL); 64 65 /* If '_p_initialize' was not found, the main program is likely not 66 written in Pascal. */ 67 if (msym.minsym == NULL) 68 return NULL; 69 70 msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL); 71 if (msym.minsym != NULL) 72 { 73 return GPC_MAIN_PROGRAM_NAME_1; 74 } 75 76 msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL); 77 if (msym.minsym != NULL) 78 { 79 return GPC_MAIN_PROGRAM_NAME_2; 80 } 81 82 /* No known entry procedure found, the main program is probably 83 not compiled with GPC. */ 84 return NULL; 85 } 86 87 /* Determines if type TYPE is a pascal string type. 88 Returns a positive value if the type is a known pascal string type. 89 This function is used by p-valprint.c code to allow better string display. 90 If it is a pascal string type, then it also sets info needed 91 to get the length and the data of the string 92 length_pos, length_size and string_pos are given in bytes. 93 char_size gives the element size in bytes. 94 FIXME: if the position or the size of these fields 95 are not multiple of TARGET_CHAR_BIT then the results are wrong 96 but this does not happen for Free Pascal nor for GPC. */ 97 int 98 is_pascal_string_type (struct type *type,int *length_pos, 99 int *length_size, int *string_pos, 100 struct type **char_type, 101 const char **arrayname) 102 { 103 if (type != NULL && type->code () == TYPE_CODE_STRUCT) 104 { 105 /* Old Borland type pascal strings from Free Pascal Compiler. */ 106 /* Two fields: length and st. */ 107 if (type->num_fields () == 2 108 && TYPE_FIELD_NAME (type, 0) 109 && strcmp (TYPE_FIELD_NAME (type, 0), "length") == 0 110 && TYPE_FIELD_NAME (type, 1) 111 && strcmp (TYPE_FIELD_NAME (type, 1), "st") == 0) 112 { 113 if (length_pos) 114 *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT; 115 if (length_size) 116 *length_size = TYPE_LENGTH (type->field (0).type ()); 117 if (string_pos) 118 *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT; 119 if (char_type) 120 *char_type = TYPE_TARGET_TYPE (type->field (1).type ()); 121 if (arrayname) 122 *arrayname = TYPE_FIELD_NAME (type, 1); 123 return 2; 124 }; 125 /* GNU pascal strings. */ 126 /* Three fields: Capacity, length and schema$ or _p_schema. */ 127 if (type->num_fields () == 3 128 && TYPE_FIELD_NAME (type, 0) 129 && strcmp (TYPE_FIELD_NAME (type, 0), "Capacity") == 0 130 && TYPE_FIELD_NAME (type, 1) 131 && strcmp (TYPE_FIELD_NAME (type, 1), "length") == 0) 132 { 133 if (length_pos) 134 *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT; 135 if (length_size) 136 *length_size = TYPE_LENGTH (type->field (1).type ()); 137 if (string_pos) 138 *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT; 139 /* FIXME: how can I detect wide chars in GPC ?? */ 140 if (char_type) 141 { 142 *char_type = TYPE_TARGET_TYPE (type->field (2).type ()); 143 144 if ((*char_type)->code () == TYPE_CODE_ARRAY) 145 *char_type = TYPE_TARGET_TYPE (*char_type); 146 } 147 if (arrayname) 148 *arrayname = TYPE_FIELD_NAME (type, 2); 149 return 3; 150 }; 151 } 152 return 0; 153 } 154 155 static void pascal_one_char (int, struct ui_file *, int *); 156 157 /* Print the character C on STREAM as part of the contents of a literal 158 string. 159 In_quotes is reset to 0 if a char is written with #4 notation. */ 160 161 static void 162 pascal_one_char (int c, struct ui_file *stream, int *in_quotes) 163 { 164 if (c == '\'' || ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c)))) 165 { 166 if (!(*in_quotes)) 167 fputs_filtered ("'", stream); 168 *in_quotes = 1; 169 if (c == '\'') 170 { 171 fputs_filtered ("''", stream); 172 } 173 else 174 fprintf_filtered (stream, "%c", c); 175 } 176 else 177 { 178 if (*in_quotes) 179 fputs_filtered ("'", stream); 180 *in_quotes = 0; 181 fprintf_filtered (stream, "#%d", (unsigned int) c); 182 } 183 } 184 185 void 186 pascal_printchar (int c, struct type *type, struct ui_file *stream) 187 { 188 int in_quotes = 0; 189 190 pascal_one_char (c, stream, &in_quotes); 191 if (in_quotes) 192 fputs_filtered ("'", stream); 193 } 194 195 196 197 /* Table mapping opcodes into strings for printing operators 198 and precedences of the operators. */ 199 200 const struct op_print pascal_op_print_tab[] = 201 { 202 {",", BINOP_COMMA, PREC_COMMA, 0}, 203 {":=", BINOP_ASSIGN, PREC_ASSIGN, 1}, 204 {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0}, 205 {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0}, 206 {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0}, 207 {"=", BINOP_EQUAL, PREC_EQUAL, 0}, 208 {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0}, 209 {"<=", BINOP_LEQ, PREC_ORDER, 0}, 210 {">=", BINOP_GEQ, PREC_ORDER, 0}, 211 {">", BINOP_GTR, PREC_ORDER, 0}, 212 {"<", BINOP_LESS, PREC_ORDER, 0}, 213 {"shr", BINOP_RSH, PREC_SHIFT, 0}, 214 {"shl", BINOP_LSH, PREC_SHIFT, 0}, 215 {"+", BINOP_ADD, PREC_ADD, 0}, 216 {"-", BINOP_SUB, PREC_ADD, 0}, 217 {"*", BINOP_MUL, PREC_MUL, 0}, 218 {"/", BINOP_DIV, PREC_MUL, 0}, 219 {"div", BINOP_INTDIV, PREC_MUL, 0}, 220 {"mod", BINOP_REM, PREC_MUL, 0}, 221 {"@", BINOP_REPEAT, PREC_REPEAT, 0}, 222 {"-", UNOP_NEG, PREC_PREFIX, 0}, 223 {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0}, 224 {"^", UNOP_IND, PREC_SUFFIX, 1}, 225 {"@", UNOP_ADDR, PREC_PREFIX, 0}, 226 {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0}, 227 {NULL, OP_NULL, PREC_PREFIX, 0} 228 }; 229 230 enum pascal_primitive_types { 231 pascal_primitive_type_int, 232 pascal_primitive_type_long, 233 pascal_primitive_type_short, 234 pascal_primitive_type_char, 235 pascal_primitive_type_float, 236 pascal_primitive_type_double, 237 pascal_primitive_type_void, 238 pascal_primitive_type_long_long, 239 pascal_primitive_type_signed_char, 240 pascal_primitive_type_unsigned_char, 241 pascal_primitive_type_unsigned_short, 242 pascal_primitive_type_unsigned_int, 243 pascal_primitive_type_unsigned_long, 244 pascal_primitive_type_unsigned_long_long, 245 pascal_primitive_type_long_double, 246 pascal_primitive_type_complex, 247 pascal_primitive_type_double_complex, 248 nr_pascal_primitive_types 249 }; 250 251 static const char *p_extensions[] = 252 { 253 ".pas", ".p", ".pp", NULL 254 }; 255 256 /* Constant data representing the Pascal language. */ 257 258 extern const struct language_data pascal_language_data = 259 { 260 "pascal", /* Language name */ 261 "Pascal", 262 language_pascal, 263 range_check_on, 264 case_sensitive_on, 265 array_row_major, 266 macro_expansion_no, 267 p_extensions, 268 &exp_descriptor_standard, 269 "this", /* name_of_this */ 270 false, /* la_store_sym_names_in_linkage_form_p */ 271 pascal_op_print_tab, /* expression operators for printing */ 272 1, /* c-style arrays */ 273 0, /* String lower bound */ 274 &default_varobj_ops, 275 "{...}" /* la_struct_too_deep_ellipsis */ 276 }; 277 278 /* Class representing the Pascal language. */ 279 280 class pascal_language : public language_defn 281 { 282 public: 283 pascal_language () 284 : language_defn (language_pascal, pascal_language_data) 285 { /* Nothing. */ } 286 287 /* See language.h. */ 288 void language_arch_info (struct gdbarch *gdbarch, 289 struct language_arch_info *lai) const override 290 { 291 const struct builtin_type *builtin = builtin_type (gdbarch); 292 293 lai->string_char_type = builtin->builtin_char; 294 lai->primitive_type_vector 295 = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1, 296 struct type *); 297 lai->primitive_type_vector [pascal_primitive_type_int] 298 = builtin->builtin_int; 299 lai->primitive_type_vector [pascal_primitive_type_long] 300 = builtin->builtin_long; 301 lai->primitive_type_vector [pascal_primitive_type_short] 302 = builtin->builtin_short; 303 lai->primitive_type_vector [pascal_primitive_type_char] 304 = builtin->builtin_char; 305 lai->primitive_type_vector [pascal_primitive_type_float] 306 = builtin->builtin_float; 307 lai->primitive_type_vector [pascal_primitive_type_double] 308 = builtin->builtin_double; 309 lai->primitive_type_vector [pascal_primitive_type_void] 310 = builtin->builtin_void; 311 lai->primitive_type_vector [pascal_primitive_type_long_long] 312 = builtin->builtin_long_long; 313 lai->primitive_type_vector [pascal_primitive_type_signed_char] 314 = builtin->builtin_signed_char; 315 lai->primitive_type_vector [pascal_primitive_type_unsigned_char] 316 = builtin->builtin_unsigned_char; 317 lai->primitive_type_vector [pascal_primitive_type_unsigned_short] 318 = builtin->builtin_unsigned_short; 319 lai->primitive_type_vector [pascal_primitive_type_unsigned_int] 320 = builtin->builtin_unsigned_int; 321 lai->primitive_type_vector [pascal_primitive_type_unsigned_long] 322 = builtin->builtin_unsigned_long; 323 lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long] 324 = builtin->builtin_unsigned_long_long; 325 lai->primitive_type_vector [pascal_primitive_type_long_double] 326 = builtin->builtin_long_double; 327 lai->primitive_type_vector [pascal_primitive_type_complex] 328 = builtin->builtin_complex; 329 lai->primitive_type_vector [pascal_primitive_type_double_complex] 330 = builtin->builtin_double_complex; 331 332 lai->bool_type_symbol = "boolean"; 333 lai->bool_type_default = builtin->builtin_bool; 334 } 335 336 /* See language.h. */ 337 338 void print_type (struct type *type, const char *varstring, 339 struct ui_file *stream, int show, int level, 340 const struct type_print_options *flags) const override 341 { 342 pascal_print_type (type, varstring, stream, show, level, flags); 343 } 344 345 /* See language.h. */ 346 347 void value_print (struct value *val, struct ui_file *stream, 348 const struct value_print_options *options) const override 349 { 350 return pascal_value_print (val, stream, options); 351 } 352 353 /* See language.h. */ 354 355 void value_print_inner 356 (struct value *val, struct ui_file *stream, int recurse, 357 const struct value_print_options *options) const override 358 { 359 return pascal_value_print_inner (val, stream, recurse, options); 360 } 361 362 /* See language.h. */ 363 364 int parser (struct parser_state *ps) const override 365 { 366 return pascal_parse (ps); 367 } 368 369 /* See language.h. */ 370 371 void emitchar (int ch, struct type *chtype, 372 struct ui_file *stream, int quoter) const override 373 { 374 int in_quotes = 0; 375 376 pascal_one_char (ch, stream, &in_quotes); 377 if (in_quotes) 378 fputs_filtered ("'", stream); 379 } 380 381 /* See language.h. */ 382 383 void printchar (int ch, struct type *chtype, 384 struct ui_file *stream) const override 385 { 386 pascal_printchar (ch, chtype, stream); 387 } 388 389 /* See language.h. */ 390 391 void printstr (struct ui_file *stream, struct type *elttype, 392 const gdb_byte *string, unsigned int length, 393 const char *encoding, int force_ellipses, 394 const struct value_print_options *options) const override 395 { 396 enum bfd_endian byte_order = type_byte_order (elttype); 397 unsigned int i; 398 unsigned int things_printed = 0; 399 int in_quotes = 0; 400 int need_comma = 0; 401 int width; 402 403 /* Preserve ELTTYPE's original type, just set its LENGTH. */ 404 check_typedef (elttype); 405 width = TYPE_LENGTH (elttype); 406 407 /* If the string was not truncated due to `set print elements', and 408 the last byte of it is a null, we don't print that, in traditional C 409 style. */ 410 if ((!force_ellipses) && length > 0 411 && extract_unsigned_integer (string + (length - 1) * width, width, 412 byte_order) == 0) 413 length--; 414 415 if (length == 0) 416 { 417 fputs_filtered ("''", stream); 418 return; 419 } 420 421 for (i = 0; i < length && things_printed < options->print_max; ++i) 422 { 423 /* Position of the character we are examining 424 to see whether it is repeated. */ 425 unsigned int rep1; 426 /* Number of repetitions we have detected so far. */ 427 unsigned int reps; 428 unsigned long int current_char; 429 430 QUIT; 431 432 if (need_comma) 433 { 434 fputs_filtered (", ", stream); 435 need_comma = 0; 436 } 437 438 current_char = extract_unsigned_integer (string + i * width, width, 439 byte_order); 440 441 rep1 = i + 1; 442 reps = 1; 443 while (rep1 < length 444 && extract_unsigned_integer (string + rep1 * width, width, 445 byte_order) == current_char) 446 { 447 ++rep1; 448 ++reps; 449 } 450 451 if (reps > options->repeat_count_threshold) 452 { 453 if (in_quotes) 454 { 455 fputs_filtered ("', ", stream); 456 in_quotes = 0; 457 } 458 pascal_printchar (current_char, elttype, stream); 459 fprintf_filtered (stream, " %p[<repeats %u times>%p]", 460 metadata_style.style ().ptr (), 461 reps, nullptr); 462 i = rep1 - 1; 463 things_printed += options->repeat_count_threshold; 464 need_comma = 1; 465 } 466 else 467 { 468 if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char))) 469 { 470 fputs_filtered ("'", stream); 471 in_quotes = 1; 472 } 473 pascal_one_char (current_char, stream, &in_quotes); 474 ++things_printed; 475 } 476 } 477 478 /* Terminate the quotes if necessary. */ 479 if (in_quotes) 480 fputs_filtered ("'", stream); 481 482 if (force_ellipses || i < length) 483 fputs_filtered ("...", stream); 484 } 485 486 /* See language.h. */ 487 488 void print_typedef (struct type *type, struct symbol *new_symbol, 489 struct ui_file *stream) const override 490 { 491 pascal_print_typedef (type, new_symbol, stream); 492 } 493 494 /* See language.h. */ 495 496 bool is_string_type_p (struct type *type) const override 497 { 498 return is_pascal_string_type (type, nullptr, nullptr, nullptr, 499 nullptr, nullptr) > 0; 500 } 501 }; 502 503 /* Single instance of the Pascal language class. */ 504 505 static pascal_language pascal_language_defn; 506