[thirdparty/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
   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, int *char_size,
		       char **arrayname)
{
  if (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_size)
	    *char_size = 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)
        {
	  struct type *char_type;
	  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 ?? */
	  char_type = TYPE_FIELD_TYPE (type,2);
	  if (char_size && TYPE_CODE (char_type) == TYPE_CODE_ARRAY)
	    {
	      *char_size = TYPE_LENGTH (TYPE_TARGET_TYPE (char_type));
	    }
	  else if (char_size)
	    *char_size = 1;
 	  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 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 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 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, const gdb_byte *string,
		 unsigned int length, int width, int force_ellipses,
		 const struct value_print_options *options)
{
  unsigned int i;
  unsigned int things_printed = 0;
  int in_quotes = 0;
  int need_comma = 0;

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

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