[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)
{

  c &= 0xFF;			/* Avoid sign bit follies */

  if ((c == '\'') || (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 = 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 TT	139	*char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 2));
	140	if (TYPE_CODE (*char_type) == TYPE_CODE_ARRAY)
	141	char_type = TYPE_TARGET_TYPE (char_type);
58159490	142	}
e2625b33 PM	143	if (arrayname)
	144	*arrayname = TYPE_FIELDS (type)[2].name;
	145	return 3;
5598ce11 PM	146	};
	147	}
	148	return 0;
	149	}
	150
373a8247 PM	151	static void pascal_one_char (int, struct ui_file , int );
	152
	153	/* Print the character C on STREAM as part of the contents of a literal
	154	string.
	155	In_quotes is reset to 0 if a char is written with #4 notation */
	156
	157	static void
f86f5ca3	158	pascal_one_char (int c, struct ui_file stream, int in_quotes)
373a8247 PM	159	{
	160
	161	c &= 0xFF; /* Avoid sign bit follies */
	162
	163	if ((c == '\'') \|\| (PRINT_LITERAL_FORM (c)))
	164	{
	165	if (!(*in_quotes))
	166	fputs_filtered ("'", stream);
	167	*in_quotes = 1;
	168	if (c == '\'')
	169	{
	170	fputs_filtered ("''", stream);
	171	}
	172	else
	173	fprintf_filtered (stream, "%c", c);
	174	}
	175	else
	176	{
	177	if (*in_quotes)
	178	fputs_filtered ("'", stream);
	179	*in_quotes = 0;
	180	fprintf_filtered (stream, "#%d", (unsigned int) c);
	181	}
	182	}
	183
6c7a06a3 TT	184	static void pascal_emit_char (int c, struct type *type,
6c7a06a3 TT	185	struct ui_file *stream, int quoter);
373a8247 PM	186
	187	/* Print the character C on STREAM as part of the contents of a literal
	188	string whose delimiter is QUOTER. Note that that format for printing
	189	characters and strings is language specific. */
	190
	191	static void
6c7a06a3	192	pascal_emit_char (int c, struct type type, struct ui_file stream, int quoter)
373a8247 PM	193	{
	194	int in_quotes = 0;
	195	pascal_one_char (c, stream, &in_quotes);
	196	if (in_quotes)
	197	fputs_filtered ("'", stream);
	198	}
	199
	200	void
6c7a06a3	201	pascal_printchar (int c, struct type type, struct ui_file stream)
373a8247 PM	202	{
	203	int in_quotes = 0;
	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;
6c7a06a3	225	int width = TYPE_LENGTH (type);
373a8247 PM	226
	227	/* If the string was not truncated due to `set print elements', and
	228	the last byte of it is a null, we don't print that, in traditional C
	229	style. */
58159490	230	if ((!force_ellipses) && length > 0
e17a4113 UW	231	&& extract_unsigned_integer (string + (length - 1) * width, width,
e17a4113 UW	232	byte_order) == 0)
373a8247 PM	233	length--;
	234
	235	if (length == 0)
	236	{
	237	fputs_filtered ("''", stream);
	238	return;
	239	}
	240
79a45b7d	241	for (i = 0; i < length && things_printed < options->print_max; ++i)
373a8247 PM	242	{
	243	/* Position of the character we are examining
	244	to see whether it is repeated. */
	245	unsigned int rep1;
	246	/* Number of repetitions we have detected so far. */
	247	unsigned int reps;
58159490	248	unsigned long int current_char;
373a8247 PM	249
	250	QUIT;
	251
	252	if (need_comma)
	253	{
	254	fputs_filtered (", ", stream);
	255	need_comma = 0;
	256	}
	257
e17a4113 UW	258	current_char = extract_unsigned_integer (string + i * width, width,
e17a4113 UW	259	byte_order);
58159490	260
373a8247 PM	261	rep1 = i + 1;
373a8247 PM	262	reps = 1;
58159490	263	while (rep1 < length
e17a4113 UW	264	&& extract_unsigned_integer (string + rep1 * width, width,
e17a4113 UW	265	byte_order) == current_char)
373a8247 PM	266	{
	267	++rep1;
	268	++reps;
	269	}
	270
79a45b7d	271	if (reps > options->repeat_count_threshold)
373a8247 PM	272	{
	273	if (in_quotes)
	274	{
79a45b7d	275	if (options->inspect_it)
373a8247 PM	276	fputs_filtered ("\\', ", stream);
	277	else
	278	fputs_filtered ("', ", stream);
	279	in_quotes = 0;
	280	}
6c7a06a3	281	pascal_printchar (current_char, type, stream);
373a8247 PM	282	fprintf_filtered (stream, " <repeats %u times>", reps);
373a8247 PM	283	i = rep1 - 1;
79a45b7d	284	things_printed += options->repeat_count_threshold;
373a8247 PM	285	need_comma = 1;
	286	}
	287	else
	288	{
58159490	289	if ((!in_quotes) && (PRINT_LITERAL_FORM (current_char)))
373a8247	290	{
79a45b7d	291	if (options->inspect_it)
373a8247 PM	292	fputs_filtered ("\\'", stream);
	293	else
	294	fputs_filtered ("'", stream);
	295	in_quotes = 1;
	296	}
58159490	297	pascal_one_char (current_char, stream, &in_quotes);
373a8247 PM	298	++things_printed;
	299	}
	300	}
	301
	302	/* Terminate the quotes if necessary. */
	303	if (in_quotes)
	304	{
79a45b7d	305	if (options->inspect_it)
373a8247 PM	306	fputs_filtered ("\\'", stream);
	307	else
	308	fputs_filtered ("'", stream);
	309	}
	310
	311	if (force_ellipses \|\| i < length)
	312	fputs_filtered ("...", stream);
	313	}
373a8247 PM	314	\f
	315
	316	/* Table mapping opcodes into strings for printing operators
	317	and precedences of the operators. */
	318
	319	const struct op_print pascal_op_print_tab[] =
	320	{
	321	{",", BINOP_COMMA, PREC_COMMA, 0},
	322	{":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
	323	{"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
	324	{"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
	325	{"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
	326	{"=", BINOP_EQUAL, PREC_EQUAL, 0},
	327	{"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
	328	{"<=", BINOP_LEQ, PREC_ORDER, 0},
	329	{">=", BINOP_GEQ, PREC_ORDER, 0},
	330	{">", BINOP_GTR, PREC_ORDER, 0},
	331	{"<", BINOP_LESS, PREC_ORDER, 0},
	332	{"shr", BINOP_RSH, PREC_SHIFT, 0},
	333	{"shl", BINOP_LSH, PREC_SHIFT, 0},
	334	{"+", BINOP_ADD, PREC_ADD, 0},
	335	{"-", BINOP_SUB, PREC_ADD, 0},
	336	{"*", BINOP_MUL, PREC_MUL, 0},
	337	{"/", BINOP_DIV, PREC_MUL, 0},
	338	{"div", BINOP_INTDIV, PREC_MUL, 0},
	339	{"mod", BINOP_REM, PREC_MUL, 0},
	340	{"@", BINOP_REPEAT, PREC_REPEAT, 0},
	341	{"-", UNOP_NEG, PREC_PREFIX, 0},
	342	{"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
	343	{"^", UNOP_IND, PREC_SUFFIX, 1},
	344	{"@", UNOP_ADDR, PREC_PREFIX, 0},
	345	{"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
	346	{NULL, 0, 0, 0}
	347	};
	348	\f
cad351d1 UW	349	enum pascal_primitive_types {
	350	pascal_primitive_type_int,
	351	pascal_primitive_type_long,
	352	pascal_primitive_type_short,
	353	pascal_primitive_type_char,
	354	pascal_primitive_type_float,
	355	pascal_primitive_type_double,
	356	pascal_primitive_type_void,
	357	pascal_primitive_type_long_long,
	358	pascal_primitive_type_signed_char,
	359	pascal_primitive_type_unsigned_char,
	360	pascal_primitive_type_unsigned_short,
	361	pascal_primitive_type_unsigned_int,
	362	pascal_primitive_type_unsigned_long,
	363	pascal_primitive_type_unsigned_long_long,
	364	pascal_primitive_type_long_double,
	365	pascal_primitive_type_complex,
	366	pascal_primitive_type_double_complex,
	367	nr_pascal_primitive_types
373a8247 PM	368	};
373a8247 PM	369
cad351d1 UW	370	static void
	371	pascal_language_arch_info (struct gdbarch *gdbarch,
	372	struct language_arch_info *lai)
	373	{
	374	const struct builtin_type *builtin = builtin_type (gdbarch);
	375	lai->string_char_type = builtin->builtin_char;
	376	lai->primitive_type_vector
	377	= GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
	378	struct type *);
	379	lai->primitive_type_vector [pascal_primitive_type_int]
	380	= builtin->builtin_int;
	381	lai->primitive_type_vector [pascal_primitive_type_long]
	382	= builtin->builtin_long;
	383	lai->primitive_type_vector [pascal_primitive_type_short]
	384	= builtin->builtin_short;
	385	lai->primitive_type_vector [pascal_primitive_type_char]
	386	= builtin->builtin_char;
	387	lai->primitive_type_vector [pascal_primitive_type_float]
	388	= builtin->builtin_float;
	389	lai->primitive_type_vector [pascal_primitive_type_double]
	390	= builtin->builtin_double;
	391	lai->primitive_type_vector [pascal_primitive_type_void]
	392	= builtin->builtin_void;
	393	lai->primitive_type_vector [pascal_primitive_type_long_long]
	394	= builtin->builtin_long_long;
	395	lai->primitive_type_vector [pascal_primitive_type_signed_char]
	396	= builtin->builtin_signed_char;
	397	lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
	398	= builtin->builtin_unsigned_char;
	399	lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
	400	= builtin->builtin_unsigned_short;
	401	lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
	402	= builtin->builtin_unsigned_int;
	403	lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
	404	= builtin->builtin_unsigned_long;
	405	lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
	406	= builtin->builtin_unsigned_long_long;
	407	lai->primitive_type_vector [pascal_primitive_type_long_double]
	408	= builtin->builtin_long_double;
	409	lai->primitive_type_vector [pascal_primitive_type_complex]
	410	= builtin->builtin_complex;
	411	lai->primitive_type_vector [pascal_primitive_type_double_complex]
	412	= builtin->builtin_double_complex;
fbb06eb1 UW	413
	414	lai->bool_type_symbol = "boolean";
	415	lai->bool_type_default = builtin->builtin_bool;
cad351d1 UW	416	}
cad351d1 UW	417
373a8247 PM	418	const struct language_defn pascal_language_defn =
	419	{
	420	"pascal", /* Language name */
	421	language_pascal,
373a8247 PM	422	range_check_on,
373a8247 PM	423	type_check_on,
63872f9d	424	case_sensitive_on,
7ca2d3a3	425	array_row_major,
9a044a89	426	macro_expansion_no,
5f9769d1	427	&exp_descriptor_standard,
373a8247 PM	428	pascal_parse,
373a8247 PM	429	pascal_error,
e85c3284	430	null_post_parser,
373a8247 PM	431	pascal_printchar, /* Print a character constant */
	432	pascal_printstr, /* Function to print string constant */
	433	pascal_emit_char, /* Print a single char */
373a8247	434	pascal_print_type, /* Print a type using appropriate syntax */
5c6ce71d	435	pascal_print_typedef, /* Print a typedef using appropriate syntax */
373a8247 PM	436	pascal_val_print, /* Print a value using appropriate syntax */
373a8247 PM	437	pascal_value_print, /* Print a top-level value */
f636b87d	438	NULL, /* Language specific skip_trampoline */
2b2d9e11	439	"this", /* name_of_this */
5f9a71c3	440	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
b368761e	441	basic_lookup_transparent_type,/* lookup_transparent_type */
9a3d7dfd	442	NULL, /* Language specific symbol demangler */
31c27f77	443	NULL, /* Language specific class_name_from_physname */
373a8247 PM	444	pascal_op_print_tab, /* expression operators for printing */
	445	1, /* c-style arrays */
	446	0, /* String lower bound */
6084f43a	447	default_word_break_characters,
41d27058	448	default_make_symbol_completion_list,
cad351d1	449	pascal_language_arch_info,
e79af960	450	default_print_array_index,
41f1b697	451	default_pass_by_reference,
ae6a3a4c	452	default_get_string,
373a8247 PM	453	LANG_MAGIC
	454	};
	455
	456	void
fba45db2	457	_initialize_pascal_language (void)
373a8247 PM	458	{
	459	add_language (&pascal_language_defn);
	460	}