123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323 |
- /* Pascal language support routines for GDB, the GNU debugger.
- Copyright (C) 2000-2022 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 (0).loc_bitpos () / TARGET_CHAR_BIT;
- if (length_size)
- *length_size = TYPE_LENGTH (type->field (0).type ());
- if (string_pos)
- *string_pos = type->field (1).loc_bitpos () / 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 (1).loc_bitpos () / TARGET_CHAR_BIT;
- if (length_size)
- *length_size = TYPE_LENGTH (type->field (1).type ());
- if (string_pos)
- *string_pos = type->field (2).loc_bitpos () / 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))
- gdb_puts ("'", stream);
- *in_quotes = 1;
- if (c == '\'')
- {
- gdb_puts ("''", stream);
- }
- else
- gdb_printf (stream, "%c", c);
- }
- else
- {
- if (*in_quotes)
- gdb_puts ("'", stream);
- *in_quotes = 0;
- gdb_printf (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)
- gdb_puts ("'", 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)
- {
- gdb_puts ("''", 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)
- {
- gdb_puts (", ", 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)
- {
- gdb_puts ("', ", stream);
- in_quotes = 0;
- }
- printchar (current_char, elttype, stream);
- gdb_printf (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)))
- {
- gdb_puts ("'", stream);
- in_quotes = 1;
- }
- print_one_char (current_char, stream, &in_quotes);
- ++things_printed;
- }
- }
- /* Terminate the quotes if necessary. */
- if (in_quotes)
- gdb_puts ("'", stream);
- if (force_ellipses || i < length)
- gdb_puts ("...", stream);
- }
- /* Single instance of the Pascal language class. */
- static pascal_language pascal_language_defn;
|