| /* Pascal language support routines for GDB, the GNU debugger. |
| |
| Copyright (C) 2000-2021 Free Software Foundation, Inc. |
| |
| This file is part of GDB. |
| |
| This program is free software; you can redistribute it and/or modify |
| it under the terms of the GNU General Public License as published by |
| the Free Software Foundation; either version 3 of the License, or |
| (at your option) any later version. |
| |
| This program is distributed in the hope that it will be useful, |
| but WITHOUT ANY WARRANTY; without even the implied warranty of |
| MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| GNU General Public License for more details. |
| |
| You should have received a copy of the GNU General Public License |
| along with this program. If not, see <http://www.gnu.org/licenses/>. */ |
| |
| /* This file is derived from c-lang.c */ |
| |
| #include "defs.h" |
| #include "symtab.h" |
| #include "gdbtypes.h" |
| #include "expression.h" |
| #include "parser-defs.h" |
| #include "language.h" |
| #include "varobj.h" |
| #include "p-lang.h" |
| #include "valprint.h" |
| #include "value.h" |
| #include <ctype.h> |
| #include "c-lang.h" |
| #include "gdbarch.h" |
| #include "cli/cli-style.h" |
| |
| /* All GPC versions until now (2007-09-27) also define a symbol called |
| '_p_initialize'. Check for the presence of this symbol first. */ |
| static const char GPC_P_INITIALIZE[] = "_p_initialize"; |
| |
| /* The name of the symbol that GPC uses as the name of the main |
| procedure (since version 20050212). */ |
| static const char GPC_MAIN_PROGRAM_NAME_1[] = "_p__M0_main_program"; |
| |
| /* Older versions of GPC (versions older than 20050212) were using |
| a different name for the main procedure. */ |
| static const char GPC_MAIN_PROGRAM_NAME_2[] = "pascal_main_program"; |
| |
| /* Function returning the special symbol name used |
| by GPC for the main procedure in the main program |
| if it is found in minimal symbol list. |
| This function tries to find minimal symbols generated by GPC |
| so that it finds the even if the program was compiled |
| without debugging information. |
| According to information supplied by Waldeck Hebisch, |
| this should work for all versions posterior to June 2000. */ |
| |
| const char * |
| pascal_main_name (void) |
| { |
| struct bound_minimal_symbol msym; |
| |
| msym = lookup_minimal_symbol (GPC_P_INITIALIZE, NULL, NULL); |
| |
| /* If '_p_initialize' was not found, the main program is likely not |
| written in Pascal. */ |
| if (msym.minsym == NULL) |
| return NULL; |
| |
| msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL); |
| if (msym.minsym != NULL) |
| { |
| return GPC_MAIN_PROGRAM_NAME_1; |
| } |
| |
| msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL); |
| if (msym.minsym != NULL) |
| { |
| return GPC_MAIN_PROGRAM_NAME_2; |
| } |
| |
| /* No known entry procedure found, the main program is probably |
| not compiled with GPC. */ |
| return NULL; |
| } |
| |
| /* See p-lang.h. */ |
| |
| int |
| pascal_is_string_type (struct type *type,int *length_pos, int *length_size, |
| int *string_pos, struct type **char_type, |
| const char **arrayname) |
| { |
| if (type != NULL && type->code () == TYPE_CODE_STRUCT) |
| { |
| /* Old Borland type pascal strings from Free Pascal Compiler. */ |
| /* Two fields: length and st. */ |
| if (type->num_fields () == 2 |
| && type->field (0).name () |
| && strcmp (type->field (0).name (), "length") == 0 |
| && type->field (1).name () |
| && strcmp (type->field (1).name (), "st") == 0) |
| { |
| if (length_pos) |
| *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT; |
| if (length_size) |
| *length_size = TYPE_LENGTH (type->field (0).type ()); |
| if (string_pos) |
| *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT; |
| if (char_type) |
| *char_type = TYPE_TARGET_TYPE (type->field (1).type ()); |
| if (arrayname) |
| *arrayname = type->field (1).name (); |
| return 2; |
| }; |
| /* GNU pascal strings. */ |
| /* Three fields: Capacity, length and schema$ or _p_schema. */ |
| if (type->num_fields () == 3 |
| && type->field (0).name () |
| && strcmp (type->field (0).name (), "Capacity") == 0 |
| && type->field (1).name () |
| && strcmp (type->field (1).name (), "length") == 0) |
| { |
| if (length_pos) |
| *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT; |
| if (length_size) |
| *length_size = TYPE_LENGTH (type->field (1).type ()); |
| if (string_pos) |
| *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT; |
| /* FIXME: how can I detect wide chars in GPC ?? */ |
| if (char_type) |
| { |
| *char_type = TYPE_TARGET_TYPE (type->field (2).type ()); |
| |
| if ((*char_type)->code () == TYPE_CODE_ARRAY) |
| *char_type = TYPE_TARGET_TYPE (*char_type); |
| } |
| if (arrayname) |
| *arrayname = type->field (2).name (); |
| return 3; |
| }; |
| } |
| return 0; |
| } |
| |
| /* See p-lang.h. */ |
| |
| void |
| pascal_language::print_one_char (int c, struct ui_file *stream, |
| int *in_quotes) const |
| { |
| if (c == '\'' || ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c)))) |
| { |
| if (!(*in_quotes)) |
| fputs_filtered ("'", stream); |
| *in_quotes = 1; |
| if (c == '\'') |
| { |
| fputs_filtered ("''", stream); |
| } |
| else |
| fprintf_filtered (stream, "%c", c); |
| } |
| else |
| { |
| if (*in_quotes) |
| fputs_filtered ("'", stream); |
| *in_quotes = 0; |
| fprintf_filtered (stream, "#%d", (unsigned int) c); |
| } |
| } |
| |
| /* See language.h. */ |
| |
| void |
| pascal_language::printchar (int c, struct type *type, |
| struct ui_file *stream) const |
| { |
| int in_quotes = 0; |
| |
| print_one_char (c, stream, &in_quotes); |
| if (in_quotes) |
| fputs_filtered ("'", stream); |
| } |
| |
| |
| |
| /* See language.h. */ |
| |
| void pascal_language::language_arch_info |
| (struct gdbarch *gdbarch, struct language_arch_info *lai) const |
| { |
| const struct builtin_type *builtin = builtin_type (gdbarch); |
| |
| /* Helper function to allow shorter lines below. */ |
| auto add = [&] (struct type * t) |
| { |
| lai->add_primitive_type (t); |
| }; |
| |
| add (builtin->builtin_int); |
| add (builtin->builtin_long); |
| add (builtin->builtin_short); |
| add (builtin->builtin_char); |
| add (builtin->builtin_float); |
| add (builtin->builtin_double); |
| add (builtin->builtin_void); |
| add (builtin->builtin_long_long); |
| add (builtin->builtin_signed_char); |
| add (builtin->builtin_unsigned_char); |
| add (builtin->builtin_unsigned_short); |
| add (builtin->builtin_unsigned_int); |
| add (builtin->builtin_unsigned_long); |
| add (builtin->builtin_unsigned_long_long); |
| add (builtin->builtin_long_double); |
| add (builtin->builtin_complex); |
| add (builtin->builtin_double_complex); |
| |
| lai->set_string_char_type (builtin->builtin_char); |
| lai->set_bool_type (builtin->builtin_bool, "boolean"); |
| } |
| |
| /* See language.h. */ |
| |
| void |
| pascal_language::printstr (struct ui_file *stream, struct type *elttype, |
| const gdb_byte *string, unsigned int length, |
| const char *encoding, int force_ellipses, |
| const struct value_print_options *options) const |
| { |
| enum bfd_endian byte_order = type_byte_order (elttype); |
| unsigned int i; |
| unsigned int things_printed = 0; |
| int in_quotes = 0; |
| int need_comma = 0; |
| int width; |
| |
| /* Preserve ELTTYPE's original type, just set its LENGTH. */ |
| check_typedef (elttype); |
| width = TYPE_LENGTH (elttype); |
| |
| /* If the string was not truncated due to `set print elements', and |
| the last byte of it is a null, we don't print that, in traditional C |
| style. */ |
| if ((!force_ellipses) && length > 0 |
| && extract_unsigned_integer (string + (length - 1) * width, width, |
| byte_order) == 0) |
| length--; |
| |
| if (length == 0) |
| { |
| fputs_filtered ("''", stream); |
| return; |
| } |
| |
| for (i = 0; i < length && things_printed < options->print_max; ++i) |
| { |
| /* Position of the character we are examining |
| to see whether it is repeated. */ |
| unsigned int rep1; |
| /* Number of repetitions we have detected so far. */ |
| unsigned int reps; |
| unsigned long int current_char; |
| |
| QUIT; |
| |
| if (need_comma) |
| { |
| fputs_filtered (", ", stream); |
| need_comma = 0; |
| } |
| |
| current_char = extract_unsigned_integer (string + i * width, width, |
| byte_order); |
| |
| rep1 = i + 1; |
| reps = 1; |
| while (rep1 < length |
| && extract_unsigned_integer (string + rep1 * width, width, |
| byte_order) == current_char) |
| { |
| ++rep1; |
| ++reps; |
| } |
| |
| if (reps > options->repeat_count_threshold) |
| { |
| if (in_quotes) |
| { |
| fputs_filtered ("', ", stream); |
| in_quotes = 0; |
| } |
| printchar (current_char, elttype, stream); |
| fprintf_filtered (stream, " %p[<repeats %u times>%p]", |
| metadata_style.style ().ptr (), |
| reps, nullptr); |
| i = rep1 - 1; |
| things_printed += options->repeat_count_threshold; |
| need_comma = 1; |
| } |
| else |
| { |
| if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char))) |
| { |
| fputs_filtered ("'", stream); |
| in_quotes = 1; |
| } |
| print_one_char (current_char, stream, &in_quotes); |
| ++things_printed; |
| } |
| } |
| |
| /* Terminate the quotes if necessary. */ |
| if (in_quotes) |
| fputs_filtered ("'", stream); |
| |
| if (force_ellipses || i < length) |
| fputs_filtered ("...", stream); |
| } |
| |
| /* Single instance of the Pascal language class. */ |
| |
| static pascal_language pascal_language_defn; |