[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
   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);
}

/* Create a fundamental Pascal type using default reasonable for the current
   target machine.

   Some object/debugging file formats (DWARF version 1, COFF, etc) do not
   define fundamental types such as "int" or "double".  Others (stabs or
   DWARF version 2, etc) do define fundamental types.  For the formats which
   don't provide fundamental types, gdb can create such types using this
   function.

   FIXME:  Some compilers distinguish explicitly signed integral types
   (signed short, signed int, signed long) from "regular" integral types
   (short, int, long) in the debugging information.  There is some dis-
   agreement as to how useful this feature is.  In particular, gcc does
   not support this.  Also, only some debugging formats allow the
   distinction to be passed on to a debugger.  For now, we always just
   use "short", "int", or "long" as the type name, for both the implicit
   and explicitly signed types.  This also makes life easier for the
   gdb test suite since we don't have to account for the differences
   in output depending upon what the compiler and debugging format
   support.  We will probably have to re-examine the issue when gdb
   starts taking it's fundamental type information directly from the
   debugging information supplied by the compiler.  fnf@cygnus.com */

/* Note there might be some discussion about the choosen correspondance
   because it mainly reflects Free Pascal Compiler setup for now PM */


struct type *
pascal_create_fundamental_type (struct objfile *objfile, int typeid)
{
  struct type *type = NULL;

  switch (typeid)
    {
    default:
      /* FIXME:  For now, if we are asked to produce a type not in this
         language, create the equivalent of a C integer type with the
         name "<?type?>".  When all the dust settles from the type
         reconstruction work, this should probably become an error. */
      type = init_type (TYPE_CODE_INT,
			gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "<?type?>", objfile);
      warning (_("internal error: no Pascal fundamental type %d"), typeid);
      break;
    case FT_VOID:
      type = init_type (TYPE_CODE_VOID,
			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
			0, "void", objfile);
      break;
    case FT_CHAR:
      type = init_type (TYPE_CODE_CHAR,
			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
			0, "char", objfile);
      break;
    case FT_SIGNED_CHAR:
      type = init_type (TYPE_CODE_INT,
			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
			0, "shortint", objfile);
      break;
    case FT_UNSIGNED_CHAR:
      type = init_type (TYPE_CODE_INT,
			TARGET_CHAR_BIT / TARGET_CHAR_BIT,
			TYPE_FLAG_UNSIGNED, "byte", objfile);
      break;
    case FT_SHORT:
      type = init_type (TYPE_CODE_INT,
			gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "integer", objfile);
      break;
    case FT_SIGNED_SHORT:
      type = init_type (TYPE_CODE_INT,
			gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "integer", objfile);		/* FIXME-fnf */
      break;
    case FT_UNSIGNED_SHORT:
      type = init_type (TYPE_CODE_INT,
			gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
			TYPE_FLAG_UNSIGNED, "word", objfile);
      break;
    case FT_INTEGER:
      type = init_type (TYPE_CODE_INT,
			gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "longint", objfile);
      break;
    case FT_SIGNED_INTEGER:
      type = init_type (TYPE_CODE_INT,
			gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "longint", objfile);		/* FIXME -fnf */
      break;
    case FT_UNSIGNED_INTEGER:
      type = init_type (TYPE_CODE_INT,
			gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
			TYPE_FLAG_UNSIGNED, "cardinal", objfile);
      break;
    case FT_LONG:
      type = init_type (TYPE_CODE_INT,
			gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "long", objfile);
      break;
    case FT_SIGNED_LONG:
      type = init_type (TYPE_CODE_INT,
			gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "long", objfile);	/* FIXME -fnf */
      break;
    case FT_UNSIGNED_LONG:
      type = init_type (TYPE_CODE_INT,
			gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
			TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
      break;
    case FT_LONG_LONG:
      type = init_type (TYPE_CODE_INT,
			gdbarch_long_long_bit
			  (current_gdbarch) / TARGET_CHAR_BIT,
			0, "long long", objfile);
      break;
    case FT_SIGNED_LONG_LONG:
      type = init_type (TYPE_CODE_INT,
			gdbarch_long_long_bit
			  (current_gdbarch) / TARGET_CHAR_BIT,
			0, "signed long long", objfile);
      break;
    case FT_UNSIGNED_LONG_LONG:
      type = init_type (TYPE_CODE_INT,
			gdbarch_long_long_bit
			  (current_gdbarch) / TARGET_CHAR_BIT,
			TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
      break;
    case FT_FLOAT:
      type = init_type (TYPE_CODE_FLT,
			gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "float", objfile);
      break;
    case FT_DBL_PREC_FLOAT:
      type = init_type (TYPE_CODE_FLT,
			gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
			0, "double", objfile);
      break;
    case FT_EXT_PREC_FLOAT:
      type = init_type (TYPE_CODE_FLT,
			gdbarch_long_double_bit (current_gdbarch)
			  / TARGET_CHAR_BIT,
			0, "extended", objfile);
      break;
    }
  return (type);
}
\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,
  NULL,
  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_create_fundamental_type,	/* Create fundamental type in this language */
  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 */
  NULL,
  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
6aba47ca DJ	3	Copyright (C) 2000, 2002, 2003, 2004, 2005, 2007
6aba47ca DJ	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	}
297
298	/* Create a fundamental Pascal type using default reasonable for the current
299	target machine.
300
301	Some object/debugging file formats (DWARF version 1, COFF, etc) do not
302	define fundamental types such as "int" or "double". Others (stabs or
303	DWARF version 2, etc) do define fundamental types. For the formats which
304	don't provide fundamental types, gdb can create such types using this
305	function.
306
307	FIXME: Some compilers distinguish explicitly signed integral types
308	(signed short, signed int, signed long) from "regular" integral types
309	(short, int, long) in the debugging information. There is some dis-
310	agreement as to how useful this feature is. In particular, gcc does
311	not support this. Also, only some debugging formats allow the
312	distinction to be passed on to a debugger. For now, we always just
313	use "short", "int", or "long" as the type name, for both the implicit
314	and explicitly signed types. This also makes life easier for the
315	gdb test suite since we don't have to account for the differences
316	in output depending upon what the compiler and debugging format
317	support. We will probably have to re-examine the issue when gdb
318	starts taking it's fundamental type information directly from the
319	debugging information supplied by the compiler. fnf@cygnus.com */
320
321	/* Note there might be some discussion about the choosen correspondance
322	because it mainly reflects Free Pascal Compiler setup for now PM */
323
324
325	struct type *
fba45db2	326	pascal_create_fundamental_type (struct objfile *objfile, int typeid)
373a8247	327	{
f86f5ca3	328	struct type *type = NULL;
373a8247 PM	329
	330	switch (typeid)
	331	{
	332	default:
	333	/* FIXME: For now, if we are asked to produce a type not in this
	334	language, create the equivalent of a C integer type with the
	335	name "<?type?>". When all the dust settles from the type
	336	reconstruction work, this should probably become an error. */
	337	type = init_type (TYPE_CODE_INT,
9a76efb6	338	gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247	339	0, "<?type?>", objfile);
8a3fe4f8	340	warning (_("internal error: no Pascal fundamental type %d"), typeid);
373a8247 PM	341	break;
	342	case FT_VOID:
	343	type = init_type (TYPE_CODE_VOID,
	344	TARGET_CHAR_BIT / TARGET_CHAR_BIT,
	345	0, "void", objfile);
	346	break;
	347	case FT_CHAR:
0906b739	348	type = init_type (TYPE_CODE_CHAR,
373a8247 PM	349	TARGET_CHAR_BIT / TARGET_CHAR_BIT,
	350	0, "char", objfile);
	351	break;
	352	case FT_SIGNED_CHAR:
	353	type = init_type (TYPE_CODE_INT,
	354	TARGET_CHAR_BIT / TARGET_CHAR_BIT,
	355	0, "shortint", objfile);
	356	break;
	357	case FT_UNSIGNED_CHAR:
	358	type = init_type (TYPE_CODE_INT,
	359	TARGET_CHAR_BIT / TARGET_CHAR_BIT,
	360	TYPE_FLAG_UNSIGNED, "byte", objfile);
	361	break;
	362	case FT_SHORT:
	363	type = init_type (TYPE_CODE_INT,
9a76efb6	364	gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	365	0, "integer", objfile);
	366	break;
	367	case FT_SIGNED_SHORT:
	368	type = init_type (TYPE_CODE_INT,
9a76efb6	369	gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	370	0, "integer", objfile); /* FIXME-fnf */
	371	break;
	372	case FT_UNSIGNED_SHORT:
	373	type = init_type (TYPE_CODE_INT,
9a76efb6	374	gdbarch_short_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	375	TYPE_FLAG_UNSIGNED, "word", objfile);
	376	break;
	377	case FT_INTEGER:
	378	type = init_type (TYPE_CODE_INT,
9a76efb6	379	gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	380	0, "longint", objfile);
	381	break;
	382	case FT_SIGNED_INTEGER:
	383	type = init_type (TYPE_CODE_INT,
9a76efb6	384	gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	385	0, "longint", objfile); /* FIXME -fnf */
	386	break;
	387	case FT_UNSIGNED_INTEGER:
	388	type = init_type (TYPE_CODE_INT,
9a76efb6	389	gdbarch_int_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	390	TYPE_FLAG_UNSIGNED, "cardinal", objfile);
	391	break;
	392	case FT_LONG:
	393	type = init_type (TYPE_CODE_INT,
9a76efb6	394	gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	395	0, "long", objfile);
	396	break;
	397	case FT_SIGNED_LONG:
	398	type = init_type (TYPE_CODE_INT,
9a76efb6	399	gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	400	0, "long", objfile); /* FIXME -fnf */
	401	break;
	402	case FT_UNSIGNED_LONG:
	403	type = init_type (TYPE_CODE_INT,
9a76efb6	404	gdbarch_long_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	405	TYPE_FLAG_UNSIGNED, "unsigned long", objfile);
	406	break;
	407	case FT_LONG_LONG:
	408	type = init_type (TYPE_CODE_INT,
9a76efb6 UW	409	gdbarch_long_long_bit
9a76efb6 UW	410	(current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	411	0, "long long", objfile);
	412	break;
	413	case FT_SIGNED_LONG_LONG:
	414	type = init_type (TYPE_CODE_INT,
9a76efb6 UW	415	gdbarch_long_long_bit
9a76efb6 UW	416	(current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	417	0, "signed long long", objfile);
	418	break;
	419	case FT_UNSIGNED_LONG_LONG:
	420	type = init_type (TYPE_CODE_INT,
9a76efb6 UW	421	gdbarch_long_long_bit
9a76efb6 UW	422	(current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	423	TYPE_FLAG_UNSIGNED, "unsigned long long", objfile);
	424	break;
	425	case FT_FLOAT:
	426	type = init_type (TYPE_CODE_FLT,
ea06eb3d	427	gdbarch_float_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	428	0, "float", objfile);
	429	break;
	430	case FT_DBL_PREC_FLOAT:
	431	type = init_type (TYPE_CODE_FLT,
ea06eb3d	432	gdbarch_double_bit (current_gdbarch) / TARGET_CHAR_BIT,
373a8247 PM	433	0, "double", objfile);
	434	break;
	435	case FT_EXT_PREC_FLOAT:
	436	type = init_type (TYPE_CODE_FLT,
ea06eb3d UW	437	gdbarch_long_double_bit (current_gdbarch)
ea06eb3d UW	438	/ TARGET_CHAR_BIT,
373a8247 PM	439	0, "extended", objfile);
	440	break;
	441	}
	442	return (type);
	443	}
	444	\f
	445
	446	/* Table mapping opcodes into strings for printing operators
	447	and precedences of the operators. */
	448
	449	const struct op_print pascal_op_print_tab[] =
	450	{
	451	{",", BINOP_COMMA, PREC_COMMA, 0},
	452	{":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
	453	{"or", BINOP_BITWISE_IOR, PREC_BITWISE_IOR, 0},
	454	{"xor", BINOP_BITWISE_XOR, PREC_BITWISE_XOR, 0},
	455	{"and", BINOP_BITWISE_AND, PREC_BITWISE_AND, 0},
	456	{"=", BINOP_EQUAL, PREC_EQUAL, 0},
	457	{"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
	458	{"<=", BINOP_LEQ, PREC_ORDER, 0},
	459	{">=", BINOP_GEQ, PREC_ORDER, 0},
	460	{">", BINOP_GTR, PREC_ORDER, 0},
	461	{"<", BINOP_LESS, PREC_ORDER, 0},
	462	{"shr", BINOP_RSH, PREC_SHIFT, 0},
	463	{"shl", BINOP_LSH, PREC_SHIFT, 0},
	464	{"+", BINOP_ADD, PREC_ADD, 0},
	465	{"-", BINOP_SUB, PREC_ADD, 0},
	466	{"*", BINOP_MUL, PREC_MUL, 0},
	467	{"/", BINOP_DIV, PREC_MUL, 0},
	468	{"div", BINOP_INTDIV, PREC_MUL, 0},
	469	{"mod", BINOP_REM, PREC_MUL, 0},
	470	{"@", BINOP_REPEAT, PREC_REPEAT, 0},
	471	{"-", UNOP_NEG, PREC_PREFIX, 0},
	472	{"not", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
	473	{"^", UNOP_IND, PREC_SUFFIX, 1},
	474	{"@", UNOP_ADDR, PREC_PREFIX, 0},
	475	{"sizeof", UNOP_SIZEOF, PREC_PREFIX, 0},
	476	{NULL, 0, 0, 0}
	477	};
	478	\f
cad351d1 UW	479	enum pascal_primitive_types {
	480	pascal_primitive_type_int,
	481	pascal_primitive_type_long,
	482	pascal_primitive_type_short,
	483	pascal_primitive_type_char,
	484	pascal_primitive_type_float,
	485	pascal_primitive_type_double,
	486	pascal_primitive_type_void,
	487	pascal_primitive_type_long_long,
	488	pascal_primitive_type_signed_char,
	489	pascal_primitive_type_unsigned_char,
	490	pascal_primitive_type_unsigned_short,
	491	pascal_primitive_type_unsigned_int,
	492	pascal_primitive_type_unsigned_long,
	493	pascal_primitive_type_unsigned_long_long,
	494	pascal_primitive_type_long_double,
	495	pascal_primitive_type_complex,
	496	pascal_primitive_type_double_complex,
	497	nr_pascal_primitive_types
373a8247 PM	498	};
373a8247 PM	499
cad351d1 UW	500	static void
	501	pascal_language_arch_info (struct gdbarch *gdbarch,
	502	struct language_arch_info *lai)
	503	{
	504	const struct builtin_type *builtin = builtin_type (gdbarch);
	505	lai->string_char_type = builtin->builtin_char;
	506	lai->primitive_type_vector
	507	= GDBARCH_OBSTACK_CALLOC (gdbarch, nr_pascal_primitive_types + 1,
	508	struct type *);
	509	lai->primitive_type_vector [pascal_primitive_type_int]
	510	= builtin->builtin_int;
	511	lai->primitive_type_vector [pascal_primitive_type_long]
	512	= builtin->builtin_long;
	513	lai->primitive_type_vector [pascal_primitive_type_short]
	514	= builtin->builtin_short;
	515	lai->primitive_type_vector [pascal_primitive_type_char]
	516	= builtin->builtin_char;
	517	lai->primitive_type_vector [pascal_primitive_type_float]
	518	= builtin->builtin_float;
	519	lai->primitive_type_vector [pascal_primitive_type_double]
	520	= builtin->builtin_double;
	521	lai->primitive_type_vector [pascal_primitive_type_void]
	522	= builtin->builtin_void;
	523	lai->primitive_type_vector [pascal_primitive_type_long_long]
	524	= builtin->builtin_long_long;
	525	lai->primitive_type_vector [pascal_primitive_type_signed_char]
	526	= builtin->builtin_signed_char;
	527	lai->primitive_type_vector [pascal_primitive_type_unsigned_char]
	528	= builtin->builtin_unsigned_char;
	529	lai->primitive_type_vector [pascal_primitive_type_unsigned_short]
	530	= builtin->builtin_unsigned_short;
	531	lai->primitive_type_vector [pascal_primitive_type_unsigned_int]
	532	= builtin->builtin_unsigned_int;
	533	lai->primitive_type_vector [pascal_primitive_type_unsigned_long]
	534	= builtin->builtin_unsigned_long;
	535	lai->primitive_type_vector [pascal_primitive_type_unsigned_long_long]
	536	= builtin->builtin_unsigned_long_long;
	537	lai->primitive_type_vector [pascal_primitive_type_long_double]
	538	= builtin->builtin_long_double;
	539	lai->primitive_type_vector [pascal_primitive_type_complex]
	540	= builtin->builtin_complex;
	541	lai->primitive_type_vector [pascal_primitive_type_double_complex]
	542	= builtin->builtin_double_complex;
	543	}
	544
373a8247 PM	545	const struct language_defn pascal_language_defn =
	546	{
	547	"pascal", /* Language name */
	548	language_pascal,
cad351d1	549	NULL,
373a8247 PM	550	range_check_on,
373a8247 PM	551	type_check_on,
63872f9d	552	case_sensitive_on,
7ca2d3a3	553	array_row_major,
5f9769d1	554	&exp_descriptor_standard,
373a8247 PM	555	pascal_parse,
373a8247 PM	556	pascal_error,
e85c3284	557	null_post_parser,
373a8247 PM	558	pascal_printchar, /* Print a character constant */
	559	pascal_printstr, /* Function to print string constant */
	560	pascal_emit_char, /* Print a single char */
	561	pascal_create_fundamental_type, /* Create fundamental type in this language */
	562	pascal_print_type, /* Print a type using appropriate syntax */
	563	pascal_val_print, /* Print a value using appropriate syntax */
	564	pascal_value_print, /* Print a top-level value */
f636b87d	565	NULL, /* Language specific skip_trampoline */
5f9a71c3 DC	566	value_of_this, /* value_of_this */
5f9a71c3 DC	567	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
b368761e	568	basic_lookup_transparent_type,/* lookup_transparent_type */
9a3d7dfd	569	NULL, /* Language specific symbol demangler */
31c27f77	570	NULL, /* Language specific class_name_from_physname */
373a8247 PM	571	pascal_op_print_tab, /* expression operators for printing */
	572	1, /* c-style arrays */
	573	0, /* String lower bound */
cad351d1	574	NULL,
6084f43a	575	default_word_break_characters,
cad351d1	576	pascal_language_arch_info,
e79af960	577	default_print_array_index,
41f1b697	578	default_pass_by_reference,
373a8247 PM	579	LANG_MAGIC
	580	};
	581
	582	void
fba45db2	583	_initialize_pascal_language (void)
373a8247 PM	584	{
	585	add_language (&pascal_language_defn);
	586	}