[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 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_CODE (type) == TYPE_CODE_STRUCT)
    {
      /* Old Borland type pascal strings from Free Pascal Compiler.  */
      /* Two fields: length and st.  */
      if (TYPE_NFIELDS (type) == 2 
          && strcmp (TYPE_FIELDS (type)[0].name, "length") == 0 
          && strcmp (TYPE_FIELDS (type)[1].name, "st") == 0)
        {
          if (length_pos)
	    *length_pos = TYPE_FIELD_BITPOS (type, 0) / TARGET_CHAR_BIT;
          if (length_size)
	    *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 0));
          if (string_pos)
	    *string_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
          if (char_type)
	    *char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 1));
 	  if (arrayname)
	    *arrayname = TYPE_FIELDS (type)[1].name;
         return 2;
        };
      /* GNU pascal strings.  */
      /* Three fields: Capacity, length and schema$ or _p_schema.  */
      if (TYPE_NFIELDS (type) == 3
          && strcmp (TYPE_FIELDS (type)[0].name, "Capacity") == 0
          && strcmp (TYPE_FIELDS (type)[1].name, "length") == 0)
        {
	  if (length_pos)
	    *length_pos = TYPE_FIELD_BITPOS (type, 1) / TARGET_CHAR_BIT;
	  if (length_size)
	    *length_size = TYPE_LENGTH (TYPE_FIELD_TYPE (type, 1));
	  if (string_pos)
	    *string_pos = TYPE_FIELD_BITPOS (type, 2) / TARGET_CHAR_BIT;
          /* FIXME: how can I detect wide chars in GPC ?? */
          if (char_type)
	    {
	      *char_type = TYPE_TARGET_TYPE (TYPE_FIELD_TYPE (type, 2));
	      if (TYPE_CODE (*char_type) == TYPE_CODE_ARRAY)
		*char_type = TYPE_TARGET_TYPE (*char_type);
	    }
 	  if (arrayname)
	    *arrayname = TYPE_FIELDS (type)[2].name;
         return 3;
        };
    }
  return 0;
}

static void pascal_one_char (int, struct ui_file *, int *);

/* Print the character C on STREAM as part of the contents of a literal
   string.
   In_quotes is reset to 0 if a char is written with #4 notation */

static void
pascal_one_char (int c, struct ui_file *stream, int *in_quotes)
{

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

  if ((c == '\'') || (PRINT_LITERAL_FORM (c)))
    {
      if (!(*in_quotes))
	fputs_filtered ("'", stream);
      *in_quotes = 1;
      if (c == '\'')
	{
	  fputs_filtered ("''", stream);
	}
      else
	fprintf_filtered (stream, "%c", c);
    }
  else
    {
      if (*in_quotes)
	fputs_filtered ("'", stream);
      *in_quotes = 0;
      fprintf_filtered (stream, "#%d", (unsigned int) c);
    }
}

static void pascal_emit_char (int c, struct type *type,
			      struct ui_file *stream, int quoter);

/* Print the character C on STREAM as part of the contents of a literal
   string whose delimiter is QUOTER.  Note that that format for printing
   characters and strings is language specific. */

static void
pascal_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
{
  int in_quotes = 0;
  pascal_one_char (c, stream, &in_quotes);
  if (in_quotes)
    fputs_filtered ("'", stream);
}

void
pascal_printchar (int c, struct type *type, struct ui_file *stream)
{
  int in_quotes = 0;
  pascal_one_char (c, stream, &in_quotes);
  if (in_quotes)
    fputs_filtered ("'", stream);
}

/* Print the character string STRING, printing at most LENGTH characters.
   Printing stops early if the number hits print_max; repeat counts
   are printed as appropriate.  Print ellipses at the end if we
   had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.  */

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