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