[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
   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,
		 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 && string[length - 1] == '\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;

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