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

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

   Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007, 2008
   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 1 if the type is a known pascal 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)
        {
          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_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)
{
  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 && string[length - 1] == '\0')
    length--;

  if (length == 0)
    {
      fputs_filtered ("''", stream);
      return;
    }

  for (i = 0; i < length && things_printed < 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;

      QUIT;

      if (need_comma)
	{
	  fputs_filtered (", ", stream);
	  need_comma = 0;
	}

      rep1 = i + 1;
      reps = 1;
      while (rep1 < length && string[rep1] == string[i])
	{
	  ++rep1;
	  ++reps;
	}

      if (reps > repeat_count_threshold)
	{
	  if (in_quotes)
	    {
	      if (inspect_it)
		fputs_filtered ("\\', ", stream);
	      else
		fputs_filtered ("', ", stream);
	      in_quotes = 0;
	    }
	  pascal_printchar (string[i], stream);
	  fprintf_filtered (stream, " <repeats %u times>", reps);
	  i = rep1 - 1;
	  things_printed += repeat_count_threshold;
	  need_comma = 1;
	}
      else
	{
	  int c = string[i];
	  if ((!in_quotes) && (PRINT_LITERAL_FORM (c)))
	    {
	      if (inspect_it)
		fputs_filtered ("\\'", stream);
	      else
		fputs_filtered ("'", stream);
	      in_quotes = 1;
	    }
	  pascal_one_char (c, stream, &in_quotes);
	  ++things_printed;
	}
    }

  /* Terminate the quotes if necessary.  */
  if (in_quotes)
    {
      if (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;
}

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