[thirdparty/binutils-gdb.git] / gdb / p-lang.c

/* Pascal language support routines for GDB, the GNU debugger.

   Copyright (C) 2000-2025 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 "event-top.h"
#include "extract-store-integer.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)
{
  bound_minimal_symbol msym
    = lookup_minimal_symbol (current_program_space, GPC_P_INITIALIZE);

  /*  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 (current_program_space, GPC_MAIN_PROGRAM_NAME_1);
  if (msym.minsym != NULL)
    {
      return GPC_MAIN_PROGRAM_NAME_1;
    }

  msym
    = lookup_minimal_symbol (current_program_space, GPC_MAIN_PROGRAM_NAME_2);
  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->field (0).type ()->length ();
	  if (string_pos)
	    *string_pos = type->field (1).loc_bitpos () / TARGET_CHAR_BIT;
	  if (char_type)
	    *char_type = type->field (1).type ()->target_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->field (1).type ()->length ();
	  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->field (2).type ()->target_type ();

	      if ((*char_type)->code () == TYPE_CODE_ARRAY)
		*char_type = (*char_type)->target_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);
}

\f

/* 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 = elttype->length ();

  /* 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;
    }

  unsigned int print_max_chars = get_print_max_chars (options);
  for (i = 0; i < length && things_printed < print_max_chars; ++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;
Commit	Line	Data
	1	/* Pascal language support routines for GDB, the GNU debugger.
	2
	3	Copyright (C) 2000-2025 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 "event-top.h"
	23	#include "extract-store-integer.h"
	24	#include "symtab.h"
	25	#include "gdbtypes.h"
	26	#include "expression.h"
	27	#include "parser-defs.h"
	28	#include "language.h"
	29	#include "varobj.h"
	30	#include "p-lang.h"
	31	#include "valprint.h"
	32	#include "value.h"
	33	#include <ctype.h>
	34	#include "c-lang.h"
	35	#include "gdbarch.h"
	36	#include "cli/cli-style.h"
	37
	38	/* All GPC versions until now (2007-09-27) also define a symbol called
	39	'_p_initialize'. Check for the presence of this symbol first. */
	40	static const char GPC_P_INITIALIZE[] = "_p_initialize";
	41
	42	/* The name of the symbol that GPC uses as the name of the main
	43	procedure (since version 20050212). */
	44	static const char GPC_MAIN_PROGRAM_NAME_1[] = "_p__M0_main_program";
	45
	46	/* Older versions of GPC (versions older than 20050212) were using
	47	a different name for the main procedure. */
	48	static const char GPC_MAIN_PROGRAM_NAME_2[] = "pascal_main_program";
	49
	50	/* Function returning the special symbol name used
	51	by GPC for the main procedure in the main program
	52	if it is found in minimal symbol list.
	53	This function tries to find minimal symbols generated by GPC
	54	so that it finds the even if the program was compiled
	55	without debugging information.
	56	According to information supplied by Waldeck Hebisch,
	57	this should work for all versions posterior to June 2000. */
	58
	59	const char *
	60	pascal_main_name (void)
	61	{
	62	bound_minimal_symbol msym
	63	= lookup_minimal_symbol (current_program_space, GPC_P_INITIALIZE);
	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
	71	= lookup_minimal_symbol (current_program_space, GPC_MAIN_PROGRAM_NAME_1);
	72	if (msym.minsym != NULL)
	73	{
	74	return GPC_MAIN_PROGRAM_NAME_1;
	75	}
	76
	77	msym
	78	= lookup_minimal_symbol (current_program_space, GPC_MAIN_PROGRAM_NAME_2);
	79	if (msym.minsym != NULL)
	80	{
	81	return GPC_MAIN_PROGRAM_NAME_2;
	82	}
	83
	84	/* No known entry procedure found, the main program is probably
	85	not compiled with GPC. */
	86	return NULL;
	87	}
	88
	89	/* See p-lang.h. */
	90
	91	int
	92	pascal_is_string_type (struct type type,int length_pos, int *length_size,
	93	int string_pos, struct type *char_type,
	94	const char **arrayname)
	95	{
	96	if (type != NULL && type->code () == TYPE_CODE_STRUCT)
	97	{
	98	/* Old Borland type pascal strings from Free Pascal Compiler. */
	99	/* Two fields: length and st. */
	100	if (type->num_fields () == 2
	101	&& type->field (0).name ()
	102	&& strcmp (type->field (0).name (), "length") == 0
	103	&& type->field (1).name ()
	104	&& strcmp (type->field (1).name (), "st") == 0)
	105	{
	106	if (length_pos)
	107	*length_pos = type->field (0).loc_bitpos () / TARGET_CHAR_BIT;
	108	if (length_size)
	109	*length_size = type->field (0).type ()->length ();
	110	if (string_pos)
	111	*string_pos = type->field (1).loc_bitpos () / TARGET_CHAR_BIT;
	112	if (char_type)
	113	*char_type = type->field (1).type ()->target_type ();
	114	if (arrayname)
	115	*arrayname = type->field (1).name ();
	116	return 2;
	117	};
	118	/* GNU pascal strings. */
	119	/* Three fields: Capacity, length and schema$ or _p_schema. */
	120	if (type->num_fields () == 3
	121	&& type->field (0).name ()
	122	&& strcmp (type->field (0).name (), "Capacity") == 0
	123	&& type->field (1).name ()
	124	&& strcmp (type->field (1).name (), "length") == 0)
	125	{
	126	if (length_pos)
	127	*length_pos = type->field (1).loc_bitpos () / TARGET_CHAR_BIT;
	128	if (length_size)
	129	*length_size = type->field (1).type ()->length ();
	130	if (string_pos)
	131	*string_pos = type->field (2).loc_bitpos () / TARGET_CHAR_BIT;
	132	/* FIXME: how can I detect wide chars in GPC ?? */
	133	if (char_type)
	134	{
	135	*char_type = type->field (2).type ()->target_type ();
	136
	137	if ((*char_type)->code () == TYPE_CODE_ARRAY)
	138	char_type = (char_type)->target_type ();
	139	}
	140	if (arrayname)
	141	*arrayname = type->field (2).name ();
	142	return 3;
	143	};
	144	}
	145	return 0;
	146	}
	147
	148	/* See p-lang.h. */
	149
	150	void
	151	pascal_language::print_one_char (int c, struct ui_file *stream,
	152	int *in_quotes) const
	153	{
	154	if (c == '\'' \|\| ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c))))
	155	{
	156	if (!(*in_quotes))
	157	gdb_puts ("'", stream);
	158	*in_quotes = 1;
	159	if (c == '\'')
	160	{
	161	gdb_puts ("''", stream);
	162	}
	163	else
	164	gdb_printf (stream, "%c", c);
	165	}
	166	else
	167	{
	168	if (*in_quotes)
	169	gdb_puts ("'", stream);
	170	*in_quotes = 0;
	171	gdb_printf (stream, "#%d", (unsigned int) c);
	172	}
	173	}
	174
	175	/* See language.h. */
	176
	177	void
	178	pascal_language::printchar (int c, struct type *type,
	179	struct ui_file *stream) const
	180	{
	181	int in_quotes = 0;
	182
	183	print_one_char (c, stream, &in_quotes);
	184	if (in_quotes)
	185	gdb_puts ("'", stream);
	186	}
	187
	188	\f
	189
	190	/* See language.h. */
	191
	192	void pascal_language::language_arch_info
	193	(struct gdbarch gdbarch, struct language_arch_info lai) const
	194	{
	195	const struct builtin_type *builtin = builtin_type (gdbarch);
	196
	197	/* Helper function to allow shorter lines below. */
	198	auto add = [&] (struct type * t)
	199	{
	200	lai->add_primitive_type (t);
	201	};
	202
	203	add (builtin->builtin_int);
	204	add (builtin->builtin_long);
	205	add (builtin->builtin_short);
	206	add (builtin->builtin_char);
	207	add (builtin->builtin_float);
	208	add (builtin->builtin_double);
	209	add (builtin->builtin_void);
	210	add (builtin->builtin_long_long);
	211	add (builtin->builtin_signed_char);
	212	add (builtin->builtin_unsigned_char);
	213	add (builtin->builtin_unsigned_short);
	214	add (builtin->builtin_unsigned_int);
	215	add (builtin->builtin_unsigned_long);
	216	add (builtin->builtin_unsigned_long_long);
	217	add (builtin->builtin_long_double);
	218	add (builtin->builtin_complex);
	219	add (builtin->builtin_double_complex);
	220
	221	lai->set_string_char_type (builtin->builtin_char);
	222	lai->set_bool_type (builtin->builtin_bool, "boolean");
	223	}
	224
	225	/* See language.h. */
	226
	227	void
	228	pascal_language::printstr (struct ui_file stream, struct type elttype,
	229	const gdb_byte *string, unsigned int length,
	230	const char *encoding, int force_ellipses,
	231	const struct value_print_options *options) const
	232	{
	233	enum bfd_endian byte_order = type_byte_order (elttype);
	234	unsigned int i;
	235	unsigned int things_printed = 0;
	236	int in_quotes = 0;
	237	int need_comma = 0;
	238	int width;
	239
	240	/* Preserve ELTTYPE's original type, just set its LENGTH. */
	241	check_typedef (elttype);
	242	width = elttype->length ();
	243
	244	/* If the string was not truncated due to `set print elements', and
	245	the last byte of it is a null, we don't print that, in traditional C
	246	style. */
	247	if ((!force_ellipses) && length > 0
	248	&& extract_unsigned_integer (string + (length - 1) * width, width,
	249	byte_order) == 0)
	250	length--;
	251
	252	if (length == 0)
	253	{
	254	gdb_puts ("''", stream);
	255	return;
	256	}
	257
	258	unsigned int print_max_chars = get_print_max_chars (options);
	259	for (i = 0; i < length && things_printed < print_max_chars; ++i)
	260	{
	261	/* Position of the character we are examining
	262	to see whether it is repeated. */
	263	unsigned int rep1;
	264	/* Number of repetitions we have detected so far. */
	265	unsigned int reps;
	266	unsigned long int current_char;
	267
	268	QUIT;
	269
	270	if (need_comma)
	271	{
	272	gdb_puts (", ", stream);
	273	need_comma = 0;
	274	}
	275
	276	current_char = extract_unsigned_integer (string + i * width, width,
	277	byte_order);
	278
	279	rep1 = i + 1;
	280	reps = 1;
	281	while (rep1 < length
	282	&& extract_unsigned_integer (string + rep1 * width, width,
	283	byte_order) == current_char)
	284	{
	285	++rep1;
	286	++reps;
	287	}
	288
	289	if (reps > options->repeat_count_threshold)
	290	{
	291	if (in_quotes)
	292	{
	293	gdb_puts ("', ", stream);
	294	in_quotes = 0;
	295	}
	296	printchar (current_char, elttype, stream);
	297	gdb_printf (stream, " %p[<repeats %u times>%p]",
	298	metadata_style.style ().ptr (),
	299	reps, nullptr);
	300	i = rep1 - 1;
	301	things_printed += options->repeat_count_threshold;
	302	need_comma = 1;
	303	}
	304	else
	305	{
	306	if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
	307	{
	308	gdb_puts ("'", stream);
	309	in_quotes = 1;
	310	}
	311	print_one_char (current_char, stream, &in_quotes);
	312	++things_printed;
	313	}
	314	}
	315
	316	/* Terminate the quotes if necessary. */
	317	if (in_quotes)
	318	gdb_puts ("'", stream);
	319
	320	if (force_ellipses \|\| i < length)
	321	gdb_puts ("...", stream);
	322	}
	323
	324	/* Single instance of the Pascal language class. */
	325
	326	static pascal_language pascal_language_defn;