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

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

   Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
   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 "gdb_string.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
#include "p-lang.h"
#include "valprint.h"
#include "value.h"
#include <ctype.h>
 
extern void _initialize_pascal_language (void);


/* 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 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 == NULL)
    return NULL;

  msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL);
  if (msym != NULL)
    {
      return GPC_MAIN_PROGRAM_NAME_1;
    }

  msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL);
  if (msym != NULL)
    {
      return GPC_MAIN_PROGRAM_NAME_2;
    }

  /*  No known entry procedure found, the main program is probably
      not compiled with GPC.  */
  return NULL;
}

/* Determines if type TYPE is a pascal string type.
   Returns a positive value if the type is a known pascal string type.
   This function is used by p-valprint.c code to allow better string display.
   If it is a pascal string type, then it also sets info needed
   to get the length and the data of the string
   length_pos, length_size and string_pos are given in bytes.
   char_size gives the element size in bytes.
   FIXME: if the position or the size of these fields
   are not multiple of TARGET_CHAR_BIT then the results are wrong
   but this does not happen for Free Pascal nor for GPC.  */
int
is_pascal_string_type (struct type *type,int *length_pos,
                       int *length_size, int *string_pos,
		       struct type **char_type,
		       char **arrayname)
{
  if (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT)
    {
      /* Old Borland type pascal strings from Free Pascal Compiler.  */
      /* Two fields: length and st.  */
      if (TYPE_NFIELDS (type) == 2 
          && strcmp (TYPE_FIELDS (type)[0].name, "length") == 0 
          && strcmp (TYPE_FIELDS (type)[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_TYPE (type, 0));
          if (string_pos)
	    *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
          if (char_type)
	    *char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 1));
 	  if (arrayname)
	    *arrayname = TYPE_FIELDS (type)[1].name;
         return 2;
        };
      /* GNU pascal strings.  */
      /* Three fields: Capacity, length and schema$ or _p_schema.  */
      if (TYPE_NFIELDS (type) == 3
          && strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0
          && strcmp (TYPE_FIELDS (type)[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_TYPE (type, 1));
	  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_TYPE (type, 2));

	      if (TYPE_CODE (*char_type) == TYPE_CODE_ARRAY)
		*char_type = TYPE_TARGET_TYPE (*char_type);
	    }
 	  if (arrayname)
	    *arrayname = TYPE_FIELDS (type)[2].name;
         return 3;
        };
    }
  return 0;
}

static void pascal_one_char (int, struct ui_file *, int *);

/* Print the character C on STREAM as part of the contents of a literal
   string.
   In_quotes is reset to 0 if a char is written with #4 notation */

static void
pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
{
  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);
    }
}

static void pascal_emit_char (int c, struct type *type,
			      struct ui_file *stream, int quoter);

/* Print the character C on STREAM as part of the contents of a literal
   string whose delimiter is QUOTER.  Note that that format for printing
   characters and strings is language specific. */

static void
pascal_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
{
  int in_quotes = 0;

  pascal_one_char (c, stream, &in_quotes);
  if (in_quotes)
    fputs_filtered ("'", stream);
}

void
pascal_printchar (int c, struct type *type, struct ui_file *stream)
{
  int in_quotes = 0;

  pascal_one_char (c, stream, &in_quotes);
  if (in_quotes)
    fputs_filtered ("'", stream);
}

/* Print the character string STRING, printing at most LENGTH characters.
   Printing stops early if the number hits print_max; repeat counts
   are printed as appropriate.  Print ellipses at the end if we
   had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.  */

void
pascal_printstr (struct ui_file *stream, struct type *type,
		 const gdb_byte *string, unsigned int length,
		 const char *encoding, int force_ellipses,
		 const struct value_print_options *options)
{
  enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
  unsigned int i;
  unsigned int things_printed = 0;
  int in_quotes = 0;
  int need_comma = 0;
  int width;

  /* Preserve TYPE's original type, just set its LENGTH.  */
  check_typedef (type);
  width = TYPE_LENGTH (type);

  /* 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)
	    {
	      if (options->inspect_it)
		fputs_filtered ("\\', ", stream);
	      else
		fputs_filtered ("', ", stream);
	      in_quotes = 0;
	    }
	  pascal_printchar (current_char, type, stream);
	  fprintf_filtered (stream, " <repeats %u times>", reps);
	  i = rep1 - 1;
	  things_printed += options->repeat_count_threshold;
	  need_comma = 1;
	}
      else
	{
	  if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
	    {
	      if (options->inspect_it)
		fputs_filtered ("\\'", stream);
	      else
		fputs_filtered ("'", stream);
	      in_quotes = 1;
	    }
	  pascal_one_char (current_char, stream, &in_quotes);
	  ++things_printed;
	}
    }

  /* Terminate the quotes if necessary.  */
  if (in_quotes)
    {
      if (options->inspect_it)
	fputs_filtered ("\\'", stream);
      else
	fputs_filtered ("'", stream);
    }

  if (force_ellipses || i < length)
    fputs_filtered ("...", stream);
}
\f

/* Table mapping opcodes into strings for printing operators
   and precedences of the operators.  */

const struct op_print pascal_op_print_tab[] =
{
  {",", BINOP_COMMA, PREC_COMMA, 0},
  {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
  {"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
  {"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
  {"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
  {"=", BINOP_EQUAL, PREC_EQUAL, 0},
  {"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
  {"<=", BINOP_LEQ, PREC_ORDER, 0},
  {">=", BINOP_GEQ, PREC_ORDER, 0},
  {">", BINOP_GTR, PREC_ORDER, 0},
  {"<", BINOP_LESS, PREC_ORDER, 0},
  {"shr", BINOP_RSH, PREC_SHIFT, 0},
  {"shl", BINOP_LSH, PREC_SHIFT, 0},
  {"+", BINOP_ADD, PREC_ADD, 0},
  {"-", BINOP_SUB, PREC_ADD, 0},
  {"*", BINOP_MUL, PREC_MUL, 0},
  {"/", BINOP_DIV, PREC_MUL, 0},
  {"div", BINOP_INTDIV, PREC_MUL, 0},
  {"mod", BINOP_REM, PREC_MUL, 0},
  {"@", BINOP_REPEAT, PREC_REPEAT, 0},
  {"-", UNOP_NEG, PREC_PREFIX, 0},
  {"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
  {"^", UNOP_IND, PREC_SUFFIX, 1},
  {"@", UNOP_ADDR, PREC_PREFIX, 0},
  {"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
  {NULL, 0, 0, 0}
};
\f
enum pascal_primitive_types {
  pascal_primitive_type_int,
  pascal_primitive_type_long,
  pascal_primitive_type_short,
  pascal_primitive_type_char,
  pascal_primitive_type_float,
  pascal_primitive_type_double,
  pascal_primitive_type_void,
  pascal_primitive_type_long_long,
  pascal_primitive_type_signed_char,
  pascal_primitive_type_unsigned_char,
  pascal_primitive_type_unsigned_short,
  pascal_primitive_type_unsigned_int,
  pascal_primitive_type_unsigned_long,
  pascal_primitive_type_unsigned_long_long,
  pascal_primitive_type_long_double,
  pascal_primitive_type_complex,
  pascal_primitive_type_double_complex,
  nr_pascal_primitive_types
};

static void
pascal_language_arch_info (struct gdbarch *gdbarch,
			   struct language_arch_info *lai)
{
  const struct builtin_type *builtin = builtin_type (gdbarch);

  lai->string_char_type = builtin->builtin_char;
  lai->primitive_type_vector
    = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
                              struct type *);
  lai->primitive_type_vector [pascal_primitive_type_int]
    = builtin->builtin_int;
  lai->primitive_type_vector [pascal_primitive_type_long]
    = builtin->builtin_long;
  lai->primitive_type_vector [pascal_primitive_type_short]
    = builtin->builtin_short;
  lai->primitive_type_vector [pascal_primitive_type_char]
    = builtin->builtin_char;
  lai->primitive_type_vector [pascal_primitive_type_float]
    = builtin->builtin_float;
  lai->primitive_type_vector [pascal_primitive_type_double]
    = builtin->builtin_double;
  lai->primitive_type_vector [pascal_primitive_type_void]
    = builtin->builtin_void;
  lai->primitive_type_vector [pascal_primitive_type_long_long]
    = builtin->builtin_long_long;
  lai->primitive_type_vector [pascal_primitive_type_signed_char]
    = builtin->builtin_signed_char;
  lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
    = builtin->builtin_unsigned_char;
  lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
    = builtin->builtin_unsigned_short;
  lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
    = builtin->builtin_unsigned_int;
  lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
    = builtin->builtin_unsigned_long;
  lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
    = builtin->builtin_unsigned_long_long;
  lai->primitive_type_vector [pascal_primitive_type_long_double]
    = builtin->builtin_long_double;
  lai->primitive_type_vector [pascal_primitive_type_complex]
    = builtin->builtin_complex;
  lai->primitive_type_vector [pascal_primitive_type_double_complex]
    = builtin->builtin_double_complex;

  lai->bool_type_symbol = "boolean";
  lai->bool_type_default = builtin->builtin_bool;
}

const struct language_defn pascal_language_defn =
{
  "pascal",			/* Language name */
  language_pascal,
  range_check_on,
  type_check_on,
  case_sensitive_on,
  array_row_major,
  macro_expansion_no,
  &exp_descriptor_standard,
  pascal_parse,
  pascal_error,
  null_post_parser,
  pascal_printchar,		/* Print a character constant */
  pascal_printstr,		/* Function to print string constant */
  pascal_emit_char,		/* Print a single char */
  pascal_print_type,		/* Print a type using appropriate syntax */
  pascal_print_typedef,		/* Print a typedef using appropriate syntax */
  pascal_val_print,		/* Print a value using appropriate syntax */
  pascal_value_print,		/* Print a top-level value */
  NULL,				/* Language specific skip_trampoline */
  "this",		        /* name_of_this */
  basic_lookup_symbol_nonlocal,	/* lookup_symbol_nonlocal */
  basic_lookup_transparent_type,/* lookup_transparent_type */
  NULL,				/* Language specific symbol demangler */
  NULL,				/* Language specific class_name_from_physname */
  pascal_op_print_tab,		/* expression operators for printing */
  1,				/* c-style arrays */
  0,				/* String lower bound */
  default_word_break_characters,
  default_make_symbol_completion_list,
  pascal_language_arch_info,
  default_print_array_index,
  default_pass_by_reference,
  default_get_string,
  LANG_MAGIC
};

void
_initialize_pascal_language (void)
{
  add_language (&pascal_language_defn);
}
Commit	Line	Data
373a8247	1	/* Pascal language support routines for GDB, the GNU debugger.
ce27fb25	2
4c38e0a4	3	Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007, 2008, 2009, 2010
6aba47ca	4	Free Software Foundation, Inc.
373a8247 PM	5
	6	This file is part of GDB.
	7
	8	This program is free software; you can redistribute it and/or modify
	9	it under the terms of the GNU General Public License as published by
a9762ec7	10	the Free Software Foundation; either version 3 of the License, or
373a8247 PM	11	(at your option) any later version.
	12
	13	This program is distributed in the hope that it will be useful,
	14	but WITHOUT ANY WARRANTY; without even the implied warranty of
	15	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	16	GNU General Public License for more details.
	17
	18	You should have received a copy of the GNU General Public License
a9762ec7	19	along with this program. If not, see <http://www.gnu.org/licenses/>. */
373a8247	20
5598ce11	21	/* This file is derived from c-lang.c */
373a8247 PM	22
373a8247 PM	23	#include "defs.h"
309367d4	24	#include "gdb_string.h"
373a8247 PM	25	#include "symtab.h"
	26	#include "gdbtypes.h"
	27	#include "expression.h"
	28	#include "parser-defs.h"
	29	#include "language.h"
	30	#include "p-lang.h"
	31	#include "valprint.h"
5f9a71c3	32	#include "value.h"
5598ce11 PM	33	#include <ctype.h>
5598ce11 PM	34
373a8247	35	extern void _initialize_pascal_language (void);
5598ce11 PM	36
5598ce11 PM	37
cd6c7346 PM	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	struct minimal_symbol *msym;
	63
	64	msym = lookup_minimal_symbol (GPC_P_INITIALIZE, NULL, NULL);
	65
	66	/* If '_p_initialize' was not found, the main program is likely not
	67	written in Pascal. */
	68	if (msym == NULL)
	69	return NULL;
	70
	71	msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_1, NULL, NULL);
	72	if (msym != NULL)
	73	{
	74	return GPC_MAIN_PROGRAM_NAME_1;
	75	}
	76
	77	msym = lookup_minimal_symbol (GPC_MAIN_PROGRAM_NAME_2, NULL, NULL);
	78	if (msym != NULL)
	79	{
	80	return GPC_MAIN_PROGRAM_NAME_2;
	81	}
	82
	83	/* No known entry procedure found, the main program is probably
	84	not compiled with GPC. */
	85	return NULL;
	86	}
	87
5598ce11	88	/* Determines if type TYPE is a pascal string type.
58159490	89	Returns a positive value if the type is a known pascal string type.
5598ce11 PM	90	This function is used by p-valprint.c code to allow better string display.
	91	If it is a pascal string type, then it also sets info needed
	92	to get the length and the data of the string
	93	length_pos, length_size and string_pos are given in bytes.
	94	char_size gives the element size in bytes.
	95	FIXME: if the position or the size of these fields
	96	are not multiple of TARGET_CHAR_BIT then the results are wrong
	97	but this does not happen for Free Pascal nor for GPC. */
	98	int
	99	is_pascal_string_type (struct type type,int length_pos,
6c7a06a3 TT	100	int length_size, int string_pos,
6c7a06a3 TT	101	struct type **char_type,
e2625b33	102	char **arrayname)
5598ce11	103	{
e13eedd5	104	if (type != NULL && TYPE_CODE (type) == TYPE_CODE_STRUCT)
5598ce11 PM	105	{
	106	/* Old Borland type pascal strings from Free Pascal Compiler. */
	107	/* Two fields: length and st. */
	108	if (TYPE_NFIELDS (type) == 2
	109	&& strcmp (TYPE_FIELDS (type)[0].name, "length") == 0
	110	&& strcmp (TYPE_FIELDS (type)[1].name, "st") == 0)
	111	{
e2625b33 PM	112	if (length_pos)
	113	*length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;
	114	if (length_size)
0004e5a2	115	*length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
e2625b33 PM	116	if (string_pos)
e2625b33 PM	117	*string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
6c7a06a3 TT	118	if (char_type)
6c7a06a3 TT	119	*char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 1));
e2625b33 PM	120	if (arrayname)
	121	*arrayname = TYPE_FIELDS (type)[1].name;
	122	return 2;
5598ce11 PM	123	};
	124	/* GNU pascal strings. */
	125	/* Three fields: Capacity, length and schema$ or _p_schema. */
	126	if (TYPE_NFIELDS (type) == 3
	127	&& strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0
	128	&& strcmp (TYPE_FIELDS (type)[1].name, "length") == 0)
	129	{
58159490	130	if (length_pos)
e2625b33	131	*length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
58159490	132	if (length_size)
0004e5a2	133	*length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 1));
58159490	134	if (string_pos)
e2625b33	135	*string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;
5598ce11	136	/* FIXME: how can I detect wide chars in GPC ?? */
6c7a06a3	137	if (char_type)
58159490	138	{
6c7a06a3	139	*char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 2));
ad3bbd48	140
6c7a06a3 TT	141	if (TYPE_CODE (*char_type) == TYPE_CODE_ARRAY)
6c7a06a3 TT	142	char_type = TYPE_TARGET_TYPE (char_type);
58159490	143	}
e2625b33 PM	144	if (arrayname)
	145	*arrayname = TYPE_FIELDS (type)[2].name;
	146	return 3;
5598ce11 PM	147	};
	148	}
	149	return 0;
	150	}
	151
373a8247 PM	152	static void pascal_one_char (int, struct ui_file , int );
	153
	154	/* Print the character C on STREAM as part of the contents of a literal
	155	string.
	156	In_quotes is reset to 0 if a char is written with #4 notation */
	157
	158	static void
f86f5ca3	159	pascal_one_char (int c, struct ui_file stream, int in_quotes)
373a8247	160	{
9b79b476	161	if (c == '\'' \|\| ((unsigned int) c <= 0xff && (PRINT_LITERAL_FORM (c))))
373a8247 PM	162	{
	163	if (!(*in_quotes))
	164	fputs_filtered ("'", stream);
	165	*in_quotes = 1;
	166	if (c == '\'')
	167	{
	168	fputs_filtered ("''", stream);
	169	}
	170	else
	171	fprintf_filtered (stream, "%c", c);
	172	}
	173	else
	174	{
	175	if (*in_quotes)
	176	fputs_filtered ("'", stream);
	177	*in_quotes = 0;
	178	fprintf_filtered (stream, "#%d", (unsigned int) c);
	179	}
	180	}
	181
6c7a06a3 TT	182	static void pascal_emit_char (int c, struct type *type,
6c7a06a3 TT	183	struct ui_file *stream, int quoter);
373a8247 PM	184
	185	/* Print the character C on STREAM as part of the contents of a literal
	186	string whose delimiter is QUOTER. Note that that format for printing
	187	characters and strings is language specific. */
	188
	189	static void
6c7a06a3	190	pascal_emit_char (int c, struct type type, struct ui_file stream, int quoter)
373a8247 PM	191	{
373a8247 PM	192	int in_quotes = 0;
ad3bbd48	193
373a8247 PM	194	pascal_one_char (c, stream, &in_quotes);
	195	if (in_quotes)
	196	fputs_filtered ("'", stream);
	197	}
	198
	199	void
6c7a06a3	200	pascal_printchar (int c, struct type type, struct ui_file stream)
373a8247 PM	201	{
373a8247 PM	202	int in_quotes = 0;
ad3bbd48	203
373a8247 PM	204	pascal_one_char (c, stream, &in_quotes);
	205	if (in_quotes)
	206	fputs_filtered ("'", stream);
	207	}
	208
	209	/* Print the character string STRING, printing at most LENGTH characters.
	210	Printing stops early if the number hits print_max; repeat counts
	211	are printed as appropriate. Print ellipses at the end if we
	212	had to stop before printing LENGTH characters, or if FORCE_ELLIPSES. */
	213
	214	void
6c7a06a3 TT	215	pascal_printstr (struct ui_file stream, struct type type,
6c7a06a3 TT	216	const gdb_byte *string, unsigned int length,
be759fcf	217	const char *encoding, int force_ellipses,
79a45b7d	218	const struct value_print_options *options)
373a8247	219	{
e17a4113	220	enum bfd_endian byte_order = gdbarch_byte_order (get_type_arch (type));
f86f5ca3	221	unsigned int i;
373a8247 PM	222	unsigned int things_printed = 0;
	223	int in_quotes = 0;
	224	int need_comma = 0;
953ac07e JK	225	int width;
	226
	227	/* Preserve TYPE's original type, just set its LENGTH. */
	228	check_typedef (type);
	229	width = TYPE_LENGTH (type);
373a8247 PM	230
	231	/* If the string was not truncated due to `set print elements', and
	232	the last byte of it is a null, we don't print that, in traditional C
	233	style. */
58159490	234	if ((!force_ellipses) && length > 0
e17a4113 UW	235	&& extract_unsigned_integer (string + (length - 1) * width, width,
e17a4113 UW	236	byte_order) == 0)
373a8247 PM	237	length--;
	238
	239	if (length == 0)
	240	{
	241	fputs_filtered ("''", stream);
	242	return;
	243	}
	244
79a45b7d	245	for (i = 0; i < length && things_printed < options->print_max; ++i)
373a8247 PM	246	{
	247	/* Position of the character we are examining
	248	to see whether it is repeated. */
	249	unsigned int rep1;
	250	/* Number of repetitions we have detected so far. */
	251	unsigned int reps;
58159490	252	unsigned long int current_char;
373a8247 PM	253
	254	QUIT;
	255
	256	if (need_comma)
	257	{
	258	fputs_filtered (", ", stream);
	259	need_comma = 0;
	260	}
	261
e17a4113 UW	262	current_char = extract_unsigned_integer (string + i * width, width,
e17a4113 UW	263	byte_order);
58159490	264
373a8247 PM	265	rep1 = i + 1;
373a8247 PM	266	reps = 1;
58159490	267	while (rep1 < length
e17a4113 UW	268	&& extract_unsigned_integer (string + rep1 * width, width,
e17a4113 UW	269	byte_order) == current_char)
373a8247 PM	270	{
	271	++rep1;
	272	++reps;
	273	}
	274
79a45b7d	275	if (reps > options->repeat_count_threshold)
373a8247 PM	276	{
	277	if (in_quotes)
	278	{
79a45b7d	279	if (options->inspect_it)
373a8247 PM	280	fputs_filtered ("\\', ", stream);
	281	else
	282	fputs_filtered ("', ", stream);
	283	in_quotes = 0;
	284	}
6c7a06a3	285	pascal_printchar (current_char, type, stream);
373a8247 PM	286	fprintf_filtered (stream, " <repeats %u times>", reps);
373a8247 PM	287	i = rep1 - 1;
79a45b7d	288	things_printed += options->repeat_count_threshold;
373a8247 PM	289	need_comma = 1;
	290	}
	291	else
	292	{
58159490	293	if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
373a8247	294	{
79a45b7d	295	if (options->inspect_it)
373a8247 PM	296	fputs_filtered ("\\'", stream);
	297	else
	298	fputs_filtered ("'", stream);
	299	in_quotes = 1;
	300	}
58159490	301	pascal_one_char (current_char, stream, &in_quotes);
373a8247 PM	302	++things_printed;
	303	}
	304	}
	305
	306	/* Terminate the quotes if necessary. */
	307	if (in_quotes)
	308	{
79a45b7d	309	if (options->inspect_it)
373a8247 PM	310	fputs_filtered ("\\'", stream);
	311	else
	312	fputs_filtered ("'", stream);
	313	}
	314
	315	if (force_ellipses \|\| i < length)
	316	fputs_filtered ("...", stream);
	317	}
373a8247 PM	318	\f
	319
	320	/* Table mapping opcodes into strings for printing operators
	321	and precedences of the operators. */
	322
	323	const struct op_print pascal_op_print_tab[] =
	324	{
	325	{",", BINOP_COMMA, PREC_COMMA, 0},
	326	{":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
	327	{"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
	328	{"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
	329	{"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
	330	{"=", BINOP_EQUAL, PREC_EQUAL, 0},
	331	{"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
	332	{"<=", BINOP_LEQ, PREC_ORDER, 0},
	333	{">=", BINOP_GEQ, PREC_ORDER, 0},
	334	{">", BINOP_GTR, PREC_ORDER, 0},
	335	{"<", BINOP_LESS, PREC_ORDER, 0},
	336	{"shr", BINOP_RSH, PREC_SHIFT, 0},
	337	{"shl", BINOP_LSH, PREC_SHIFT, 0},
	338	{"+", BINOP_ADD, PREC_ADD, 0},
	339	{"-", BINOP_SUB, PREC_ADD, 0},
	340	{"*", BINOP_MUL, PREC_MUL, 0},
	341	{"/", BINOP_DIV, PREC_MUL, 0},
	342	{"div", BINOP_INTDIV, PREC_MUL, 0},
	343	{"mod", BINOP_REM, PREC_MUL, 0},
	344	{"@", BINOP_REPEAT, PREC_REPEAT, 0},
	345	{"-", UNOP_NEG, PREC_PREFIX, 0},
	346	{"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
	347	{"^", UNOP_IND, PREC_SUFFIX, 1},
	348	{"@", UNOP_ADDR, PREC_PREFIX, 0},
	349	{"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
	350	{NULL, 0, 0, 0}
	351	};
	352	\f
cad351d1 UW	353	enum pascal_primitive_types {
	354	pascal_primitive_type_int,
	355	pascal_primitive_type_long,
	356	pascal_primitive_type_short,
	357	pascal_primitive_type_char,
	358	pascal_primitive_type_float,
	359	pascal_primitive_type_double,
	360	pascal_primitive_type_void,
	361	pascal_primitive_type_long_long,
	362	pascal_primitive_type_signed_char,
	363	pascal_primitive_type_unsigned_char,
	364	pascal_primitive_type_unsigned_short,
	365	pascal_primitive_type_unsigned_int,
	366	pascal_primitive_type_unsigned_long,
	367	pascal_primitive_type_unsigned_long_long,
	368	pascal_primitive_type_long_double,
	369	pascal_primitive_type_complex,
	370	pascal_primitive_type_double_complex,
	371	nr_pascal_primitive_types
373a8247 PM	372	};
373a8247 PM	373
cad351d1 UW	374	static void
	375	pascal_language_arch_info (struct gdbarch *gdbarch,
	376	struct language_arch_info *lai)
	377	{
	378	const struct builtin_type *builtin = builtin_type (gdbarch);
ad3bbd48	379
cad351d1 UW	380	lai->string_char_type = builtin->builtin_char;
	381	lai->primitive_type_vector
	382	= GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
	383	struct type *);
	384	lai->primitive_type_vector [pascal_primitive_type_int]
	385	= builtin->builtin_int;
	386	lai->primitive_type_vector [pascal_primitive_type_long]
	387	= builtin->builtin_long;
	388	lai->primitive_type_vector [pascal_primitive_type_short]
	389	= builtin->builtin_short;
	390	lai->primitive_type_vector [pascal_primitive_type_char]
	391	= builtin->builtin_char;
	392	lai->primitive_type_vector [pascal_primitive_type_float]
	393	= builtin->builtin_float;
	394	lai->primitive_type_vector [pascal_primitive_type_double]
	395	= builtin->builtin_double;
	396	lai->primitive_type_vector [pascal_primitive_type_void]
	397	= builtin->builtin_void;
	398	lai->primitive_type_vector [pascal_primitive_type_long_long]
	399	= builtin->builtin_long_long;
	400	lai->primitive_type_vector [pascal_primitive_type_signed_char]
	401	= builtin->builtin_signed_char;
	402	lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
	403	= builtin->builtin_unsigned_char;
	404	lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
	405	= builtin->builtin_unsigned_short;
	406	lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
	407	= builtin->builtin_unsigned_int;
	408	lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
	409	= builtin->builtin_unsigned_long;
	410	lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
	411	= builtin->builtin_unsigned_long_long;
	412	lai->primitive_type_vector [pascal_primitive_type_long_double]
	413	= builtin->builtin_long_double;
	414	lai->primitive_type_vector [pascal_primitive_type_complex]
	415	= builtin->builtin_complex;
	416	lai->primitive_type_vector [pascal_primitive_type_double_complex]
	417	= builtin->builtin_double_complex;
fbb06eb1 UW	418
	419	lai->bool_type_symbol = "boolean";
	420	lai->bool_type_default = builtin->builtin_bool;
cad351d1 UW	421	}
cad351d1 UW	422
373a8247 PM	423	const struct language_defn pascal_language_defn =
	424	{
	425	"pascal", /* Language name */
	426	language_pascal,
373a8247 PM	427	range_check_on,
373a8247 PM	428	type_check_on,
63872f9d	429	case_sensitive_on,
7ca2d3a3	430	array_row_major,
9a044a89	431	macro_expansion_no,
5f9769d1	432	&exp_descriptor_standard,
373a8247 PM	433	pascal_parse,
373a8247 PM	434	pascal_error,
e85c3284	435	null_post_parser,
373a8247 PM	436	pascal_printchar, /* Print a character constant */
	437	pascal_printstr, /* Function to print string constant */
	438	pascal_emit_char, /* Print a single char */
373a8247	439	pascal_print_type, /* Print a type using appropriate syntax */
5c6ce71d	440	pascal_print_typedef, /* Print a typedef using appropriate syntax */
373a8247 PM	441	pascal_val_print, /* Print a value using appropriate syntax */
373a8247 PM	442	pascal_value_print, /* Print a top-level value */
f636b87d	443	NULL, /* Language specific skip_trampoline */
2b2d9e11	444	"this", /* name_of_this */
5f9a71c3	445	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
b368761e	446	basic_lookup_transparent_type,/* lookup_transparent_type */
9a3d7dfd	447	NULL, /* Language specific symbol demangler */
31c27f77	448	NULL, /* Language specific class_name_from_physname */
373a8247 PM	449	pascal_op_print_tab, /* expression operators for printing */
	450	1, /* c-style arrays */
	451	0, /* String lower bound */
6084f43a	452	default_word_break_characters,
41d27058	453	default_make_symbol_completion_list,
cad351d1	454	pascal_language_arch_info,
e79af960	455	default_print_array_index,
41f1b697	456	default_pass_by_reference,
ae6a3a4c	457	default_get_string,
373a8247 PM	458	LANG_MAGIC
	459	};
	460
	461	void
fba45db2	462	_initialize_pascal_language (void)
373a8247 PM	463	{
	464	add_language (&pascal_language_defn);
	465	}