[deliverable/binutils-gdb.git] / gdb / m2-lang.c

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

   Copyright (C) 1992-2016 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/>.  */

#include "defs.h"
#include "symtab.h"
#include "gdbtypes.h"
#include "expression.h"
#include "parser-defs.h"
#include "language.h"
#include "varobj.h"
#include "m2-lang.h"
#include "c-lang.h"
#include "valprint.h"

extern void _initialize_m2_language (void);
static void m2_printchar (int, struct type *, struct ui_file *);
static void m2_emit_char (int, struct type *, struct ui_file *, int);

/* 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.
   FIXME:  This is a copy of the same function from c-exp.y.  It should
   be replaced with a true Modula version.  */

static void
m2_emit_char (int c, struct type *type, struct ui_file *stream, int quoter)
{

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

  if (PRINT_LITERAL_FORM (c))
    {
      if (c == '\\' || c == quoter)
	{
	  fputs_filtered ("\\", stream);
	}
      fprintf_filtered (stream, "%c", c);
    }
  else
    {
      switch (c)
	{
	case '\n':
	  fputs_filtered ("\\n", stream);
	  break;
	case '\b':
	  fputs_filtered ("\\b", stream);
	  break;
	case '\t':
	  fputs_filtered ("\\t", stream);
	  break;
	case '\f':
	  fputs_filtered ("\\f", stream);
	  break;
	case '\r':
	  fputs_filtered ("\\r", stream);
	  break;
	case '\033':
	  fputs_filtered ("\\e", stream);
	  break;
	case '\007':
	  fputs_filtered ("\\a", stream);
	  break;
	default:
	  fprintf_filtered (stream, "\\%.3o", (unsigned int) c);
	  break;
	}
    }
}

/* FIXME:  This is a copy of the same function from c-exp.y.  It should
   be replaced with a true Modula version.  */

static void
m2_printchar (int c, struct type *type, struct ui_file *stream)
{
  fputs_filtered ("'", stream);
  LA_EMIT_CHAR (c, type, stream, '\'');
  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.
   FIXME:  This is a copy of the same function from c-exp.y.  It should
   be replaced with a true Modula version.  */

static void
m2_printstr (struct ui_file *stream, struct type *type, const gdb_byte *string,
	     unsigned int length, const char *encoding, 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 (length == 0)
    {
      fputs_filtered ("\"\"", gdb_stdout);
      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)
	    {
	      fputs_filtered ("\", ", stream);
	      in_quotes = 0;
	    }
	  m2_printchar (string[i], 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)
	    {
	      fputs_filtered ("\"", stream);
	      in_quotes = 1;
	    }
	  LA_EMIT_CHAR (string[i], type, stream, '"');
	  ++things_printed;
	}
    }

  /* Terminate the quotes if necessary.  */
  if (in_quotes)
    fputs_filtered ("\"", stream);

  if (force_ellipses || i < length)
    fputs_filtered ("...", stream);
}

static struct value *
evaluate_subexp_modula2 (struct type *expect_type, struct expression *exp,
			 int *pos, enum noside noside)
{
  enum exp_opcode op = exp->elts[*pos].opcode;
  struct value *arg1;
  struct value *arg2;
  struct type *type;

  switch (op)
    {
    case UNOP_HIGH:
      (*pos)++;
      arg1 = evaluate_subexp_with_coercion (exp, pos, noside);

      if (noside == EVAL_SKIP || noside == EVAL_AVOID_SIDE_EFFECTS)
	return arg1;
      else
	{
	  arg1 = coerce_ref (arg1);
	  type = check_typedef (value_type (arg1));

	  if (m2_is_unbounded_array (type))
	    {
	      struct value *temp = arg1;

	      type = TYPE_FIELD_TYPE (type, 1);
	      /* i18n: Do not translate the "_m2_high" part!  */
	      arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
				       _("unbounded structure "
					 "missing _m2_high field"));
	  
	      if (value_type (arg1) != type)
		arg1 = value_cast (type, arg1);
	    }
	}
      return arg1;

    case BINOP_SUBSCRIPT:
      (*pos)++;
      arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
      arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
      if (noside == EVAL_SKIP)
	goto nosideret;
      /* If the user attempts to subscript something that is not an
         array or pointer type (like a plain int variable for example),
         then report this as an error.  */

      arg1 = coerce_ref (arg1);
      type = check_typedef (value_type (arg1));

      if (m2_is_unbounded_array (type))
	{
	  struct value *temp = arg1;
	  type = TYPE_FIELD_TYPE (type, 0);
	  if (type == NULL || (TYPE_CODE (type) != TYPE_CODE_PTR))
	    {
	      warning (_("internal error: unbounded "
			 "array structure is unknown"));
	      return evaluate_subexp_standard (expect_type, exp, pos, noside);
	    }
	  /* i18n: Do not translate the "_m2_contents" part!  */
	  arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
				   _("unbounded structure "
				     "missing _m2_contents field"));
	  
	  if (value_type (arg1) != type)
	    arg1 = value_cast (type, arg1);

	  check_typedef (value_type (arg1));
	  return value_ind (value_ptradd (arg1, value_as_long (arg2)));
	}
      else
	if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
	  {
	    if (TYPE_NAME (type))
	      error (_("cannot subscript something of type `%s'"),
		     TYPE_NAME (type));
	    else
	      error (_("cannot subscript requested type"));
	  }

      if (noside == EVAL_AVOID_SIDE_EFFECTS)
	return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
      else
	return value_subscript (arg1, value_as_long (arg2));

    default:
      return evaluate_subexp_standard (expect_type, exp, pos, noside);
    }

 nosideret:
  return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
}
\f

/* Table of operators and their precedences for printing expressions.  */

static const struct op_print m2_op_print_tab[] =
{
  {"+", BINOP_ADD, PREC_ADD, 0},
  {"+", UNOP_PLUS, PREC_PREFIX, 0},
  {"-", BINOP_SUB, PREC_ADD, 0},
  {"-", UNOP_NEG, PREC_PREFIX, 0},
  {"*", BINOP_MUL, PREC_MUL, 0},
  {"/", BINOP_DIV, PREC_MUL, 0},
  {"DIV", BINOP_INTDIV, PREC_MUL, 0},
  {"MOD", BINOP_REM, PREC_MUL, 0},
  {":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
  {"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
  {"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
  {"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 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},
  {"^", UNOP_IND, PREC_PREFIX, 0},
  {"@", BINOP_REPEAT, PREC_REPEAT, 0},
  {"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
  {"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
  {"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
  {"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
  {"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
  {"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
  {"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
  {"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
  {"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
  {NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
};
\f
/* The built-in types of Modula-2.  */

enum m2_primitive_types {
  m2_primitive_type_char,
  m2_primitive_type_int,
  m2_primitive_type_card,
  m2_primitive_type_real,
  m2_primitive_type_bool,
  nr_m2_primitive_types
};

static void
m2_language_arch_info (struct gdbarch *gdbarch,
		       struct language_arch_info *lai)
{
  const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);

  lai->string_char_type = builtin->builtin_char;
  lai->primitive_type_vector
    = GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
                              struct type *);

  lai->primitive_type_vector [m2_primitive_type_char]
    = builtin->builtin_char;
  lai->primitive_type_vector [m2_primitive_type_int]
    = builtin->builtin_int;
  lai->primitive_type_vector [m2_primitive_type_card]
    = builtin->builtin_card;
  lai->primitive_type_vector [m2_primitive_type_real]
    = builtin->builtin_real;
  lai->primitive_type_vector [m2_primitive_type_bool]
    = builtin->builtin_bool;

  lai->bool_type_symbol = "BOOLEAN";
  lai->bool_type_default = builtin->builtin_bool;
}

const struct exp_descriptor exp_descriptor_modula2 = 
{
  print_subexp_standard,
  operator_length_standard,
  operator_check_standard,
  op_name_standard,
  dump_subexp_body_standard,
  evaluate_subexp_modula2
};

const struct language_defn m2_language_defn =
{
  "modula-2",
  "Modula-2",
  language_m2,
  range_check_on,
  case_sensitive_on,
  array_row_major,
  macro_expansion_no,
  NULL,
  &exp_descriptor_modula2,
  m2_parse,			/* parser */
  m2_yyerror,			/* parser error function */
  null_post_parser,
  m2_printchar,			/* Print character constant */
  m2_printstr,			/* function to print string constant */
  m2_emit_char,			/* Function to print a single character */
  m2_print_type,		/* Print a type using appropriate syntax */
  m2_print_typedef,		/* Print a typedef using appropriate syntax */
  m2_val_print,			/* Print a value using appropriate syntax */
  c_value_print,		/* Print a top-level value */
  default_read_var_value,	/* la_read_var_value */
  NULL,				/* Language specific skip_trampoline */
  NULL,		                /* name_of_this */
  basic_lookup_symbol_nonlocal,	/* lookup_symbol_nonlocal */
  basic_lookup_transparent_type,/* lookup_transparent_type */
  NULL,				/* Language specific symbol demangler */
  NULL,
  NULL,				/* Language specific
				   class_name_from_physname */
  m2_op_print_tab,		/* expression operators for printing */
  0,				/* arrays are first-class (not c-style) */
  0,				/* String lower bound */
  default_word_break_characters,
  default_make_symbol_completion_list,
  m2_language_arch_info,
  default_print_array_index,
  default_pass_by_reference,
  default_get_string,
  NULL,				/* la_get_symbol_name_cmp */
  iterate_over_symbols,
  &default_varobj_ops,
  NULL,
  NULL,
  LANG_MAGIC
};

static void *
build_m2_types (struct gdbarch *gdbarch)
{
  struct builtin_m2_type *builtin_m2_type
    = GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);

  /* Modula-2 "pervasive" types.  NOTE:  these can be redefined!!! */
  builtin_m2_type->builtin_int
    = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
  builtin_m2_type->builtin_card
    = arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
  builtin_m2_type->builtin_real
    = arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
		       gdbarch_float_format (gdbarch));
  builtin_m2_type->builtin_char
    = arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
  builtin_m2_type->builtin_bool
    = arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");

  return builtin_m2_type;
}

static struct gdbarch_data *m2_type_data;

const struct builtin_m2_type *
builtin_m2_type (struct gdbarch *gdbarch)
{
  return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
}


/* Initialization for Modula-2 */

void
_initialize_m2_language (void)
{
  m2_type_data = gdbarch_data_register_post_init (build_m2_types);

  add_language (&m2_language_defn);
}
Commit	Line	Data
c906108c	1	/* Modula 2 language support routines for GDB, the GNU debugger.
ce27fb25	2
618f726f	3	Copyright (C) 1992-2016 Free Software Foundation, Inc.
c906108c	4
c5aa993b	5	This file is part of GDB.
c906108c	6
c5aa993b JM	7	This program is free software; you can redistribute it and/or modify
c5aa993b JM	8	it under the terms of the GNU General Public License as published by
a9762ec7	9	the Free Software Foundation; either version 3 of the License, or
c5aa993b	10	(at your option) any later version.
c906108c	11
c5aa993b JM	12	This program is distributed in the hope that it will be useful,
	13	but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	GNU General Public License for more details.
c906108c	16
c5aa993b	17	You should have received a copy of the GNU General Public License
a9762ec7	18	along with this program. If not, see <http://www.gnu.org/licenses/>. */
c906108c SS	19
	20	#include "defs.h"
	21	#include "symtab.h"
	22	#include "gdbtypes.h"
	23	#include "expression.h"
	24	#include "parser-defs.h"
	25	#include "language.h"
a53b64ea	26	#include "varobj.h"
c906108c SS	27	#include "m2-lang.h"
c906108c SS	28	#include "c-lang.h"
745b8ca0	29	#include "valprint.h"
c906108c	30
a14ed312	31	extern void _initialize_m2_language (void);
6c7a06a3 TT	32	static void m2_printchar (int, struct type , struct ui_file );
6c7a06a3 TT	33	static void m2_emit_char (int, struct type , struct ui_file , int);
c906108c SS	34
	35	/* Print the character C on STREAM as part of the contents of a literal
	36	string whose delimiter is QUOTER. Note that that format for printing
	37	characters and strings is language specific.
	38	FIXME: This is a copy of the same function from c-exp.y. It should
844781a1	39	be replaced with a true Modula version. */
c906108c SS	40
c906108c SS	41	static void
6c7a06a3	42	m2_emit_char (int c, struct type type, struct ui_file stream, int quoter)
c906108c SS	43	{
c906108c SS	44
025bb325	45	c &= 0xFF; /* Avoid sign bit follies. */
c906108c SS	46
	47	if (PRINT_LITERAL_FORM (c))
	48	{
	49	if (c == '\\' \|\| c == quoter)
	50	{
	51	fputs_filtered ("\\", stream);
	52	}
	53	fprintf_filtered (stream, "%c", c);
	54	}
	55	else
	56	{
	57	switch (c)
	58	{
	59	case '\n':
	60	fputs_filtered ("\\n", stream);
	61	break;
	62	case '\b':
	63	fputs_filtered ("\\b", stream);
	64	break;
	65	case '\t':
	66	fputs_filtered ("\\t", stream);
	67	break;
	68	case '\f':
	69	fputs_filtered ("\\f", stream);
	70	break;
	71	case '\r':
	72	fputs_filtered ("\\r", stream);
	73	break;
	74	case '\033':
	75	fputs_filtered ("\\e", stream);
	76	break;
	77	case '\007':
	78	fputs_filtered ("\\a", stream);
	79	break;
	80	default:
	81	fprintf_filtered (stream, "\\%.3o", (unsigned int) c);
	82	break;
	83	}
	84	}
	85	}
	86
	87	/* FIXME: This is a copy of the same function from c-exp.y. It should
844781a1	88	be replaced with a true Modula version. */
c906108c SS	89
c906108c SS	90	static void
6c7a06a3	91	m2_printchar (int c, struct type type, struct ui_file stream)
c906108c SS	92	{
c906108c SS	93	fputs_filtered ("'", stream);
6c7a06a3	94	LA_EMIT_CHAR (c, type, stream, '\'');
c906108c SS	95	fputs_filtered ("'", stream);
	96	}
	97
	98	/* Print the character string STRING, printing at most LENGTH characters.
	99	Printing stops early if the number hits print_max; repeat counts
	100	are printed as appropriate. Print ellipses at the end if we
	101	had to stop before printing LENGTH characters, or if FORCE_ELLIPSES.
	102	FIXME: This is a copy of the same function from c-exp.y. It should
844781a1	103	be replaced with a true Modula version. */
c906108c SS	104
c906108c SS	105	static void
6c7a06a3	106	m2_printstr (struct ui_file stream, struct type type, const gdb_byte *string,
be759fcf	107	unsigned int length, const char *encoding, int force_ellipses,
79a45b7d	108	const struct value_print_options *options)
c906108c	109	{
f86f5ca3	110	unsigned int i;
c906108c SS	111	unsigned int things_printed = 0;
	112	int in_quotes = 0;
	113	int need_comma = 0;
c906108c SS	114
	115	if (length == 0)
	116	{
	117	fputs_filtered ("\"\"", gdb_stdout);
	118	return;
	119	}
	120
79a45b7d	121	for (i = 0; i < length && things_printed < options->print_max; ++i)
c906108c SS	122	{
c906108c SS	123	/* Position of the character we are examining
c5aa993b	124	to see whether it is repeated. */
c906108c SS	125	unsigned int rep1;
	126	/* Number of repetitions we have detected so far. */
	127	unsigned int reps;
	128
	129	QUIT;
	130
	131	if (need_comma)
	132	{
	133	fputs_filtered (", ", stream);
	134	need_comma = 0;
	135	}
	136
	137	rep1 = i + 1;
	138	reps = 1;
	139	while (rep1 < length && string[rep1] == string[i])
	140	{
	141	++rep1;
	142	++reps;
	143	}
	144
79a45b7d	145	if (reps > options->repeat_count_threshold)
c906108c SS	146	{
	147	if (in_quotes)
	148	{
e93a8774	149	fputs_filtered ("\", ", stream);
c906108c SS	150	in_quotes = 0;
c906108c SS	151	}
6c7a06a3	152	m2_printchar (string[i], type, stream);
c906108c SS	153	fprintf_filtered (stream, " <repeats %u times>", reps);
c906108c SS	154	i = rep1 - 1;
79a45b7d	155	things_printed += options->repeat_count_threshold;
c906108c SS	156	need_comma = 1;
	157	}
	158	else
	159	{
	160	if (!in_quotes)
	161	{
e93a8774	162	fputs_filtered ("\"", stream);
c906108c SS	163	in_quotes = 1;
c906108c SS	164	}
6c7a06a3	165	LA_EMIT_CHAR (string[i], type, stream, '"');
c906108c SS	166	++things_printed;
	167	}
	168	}
	169
	170	/* Terminate the quotes if necessary. */
	171	if (in_quotes)
e93a8774	172	fputs_filtered ("\"", stream);
c906108c SS	173
	174	if (force_ellipses \|\| i < length)
	175	fputs_filtered ("...", stream);
	176	}
	177
844781a1 GM	178	static struct value *
	179	evaluate_subexp_modula2 (struct type expect_type, struct expression exp,
	180	int *pos, enum noside noside)
	181	{
	182	enum exp_opcode op = exp->elts[*pos].opcode;
	183	struct value *arg1;
	184	struct value *arg2;
	185	struct type *type;
b8d56208	186
844781a1 GM	187	switch (op)
	188	{
	189	case UNOP_HIGH:
	190	(*pos)++;
	191	arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
	192
	193	if (noside == EVAL_SKIP \|\| noside == EVAL_AVOID_SIDE_EFFECTS)
	194	return arg1;
	195	else
	196	{
	197	arg1 = coerce_ref (arg1);
	198	type = check_typedef (value_type (arg1));
	199
	200	if (m2_is_unbounded_array (type))
	201	{
	202	struct value *temp = arg1;
b8d56208	203
844781a1 GM	204	type = TYPE_FIELD_TYPE (type, 1);
	205	/* i18n: Do not translate the "_m2_high" part! */
	206	arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
	207	_("unbounded structure "
	208	"missing _m2_high field"));
	209
	210	if (value_type (arg1) != type)
	211	arg1 = value_cast (type, arg1);
	212	}
	213	}
	214	return arg1;
	215
	216	case BINOP_SUBSCRIPT:
	217	(*pos)++;
	218	arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
	219	arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
	220	if (noside == EVAL_SKIP)
	221	goto nosideret;
	222	/* If the user attempts to subscript something that is not an
	223	array or pointer type (like a plain int variable for example),
	224	then report this as an error. */
	225
	226	arg1 = coerce_ref (arg1);
	227	type = check_typedef (value_type (arg1));
	228
	229	if (m2_is_unbounded_array (type))
	230	{
	231	struct value *temp = arg1;
	232	type = TYPE_FIELD_TYPE (type, 0);
b8d56208 MS	233	if (type == NULL \|\| (TYPE_CODE (type) != TYPE_CODE_PTR))
b8d56208 MS	234	{
025bb325 MS	235	warning (_("internal error: unbounded "
025bb325 MS	236	"array structure is unknown"));
b8d56208 MS	237	return evaluate_subexp_standard (expect_type, exp, pos, noside);
b8d56208 MS	238	}
844781a1 GM	239	/* i18n: Do not translate the "_m2_contents" part! */
	240	arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
	241	_("unbounded structure "
	242	"missing _m2_contents field"));
	243
	244	if (value_type (arg1) != type)
	245	arg1 = value_cast (type, arg1);
	246
976aa66e	247	check_typedef (value_type (arg1));
2497b498	248	return value_ind (value_ptradd (arg1, value_as_long (arg2)));
844781a1 GM	249	}
	250	else
	251	if (TYPE_CODE (type) != TYPE_CODE_ARRAY)
	252	{
	253	if (TYPE_NAME (type))
	254	error (_("cannot subscript something of type `%s'"),
	255	TYPE_NAME (type));
	256	else
	257	error (_("cannot subscript requested type"));
	258	}
	259
	260	if (noside == EVAL_AVOID_SIDE_EFFECTS)
	261	return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
	262	else
2497b498	263	return value_subscript (arg1, value_as_long (arg2));
844781a1 GM	264
	265	default:
	266	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	267	}
	268
	269	nosideret:
22601c15	270	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
844781a1	271	}
c906108c	272	\f
c5aa993b	273
c906108c SS	274	/* Table of operators and their precedences for printing expressions. */
c906108c SS	275
c5aa993b JM	276	static const struct op_print m2_op_print_tab[] =
	277	{
	278	{"+", BINOP_ADD, PREC_ADD, 0},
	279	{"+", UNOP_PLUS, PREC_PREFIX, 0},
	280	{"-", BINOP_SUB, PREC_ADD, 0},
	281	{"-", UNOP_NEG, PREC_PREFIX, 0},
	282	{"*", BINOP_MUL, PREC_MUL, 0},
	283	{"/", BINOP_DIV, PREC_MUL, 0},
	284	{"DIV", BINOP_INTDIV, PREC_MUL, 0},
	285	{"MOD", BINOP_REM, PREC_MUL, 0},
	286	{":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
	287	{"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
	288	{"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
	289	{"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
	290	{"=", BINOP_EQUAL, PREC_EQUAL, 0},
	291	{"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
	292	{"<=", BINOP_LEQ, PREC_ORDER, 0},
	293	{">=", BINOP_GEQ, PREC_ORDER, 0},
	294	{">", BINOP_GTR, PREC_ORDER, 0},
	295	{"<", BINOP_LESS, PREC_ORDER, 0},
	296	{"^", UNOP_IND, PREC_PREFIX, 0},
	297	{"@", BINOP_REPEAT, PREC_REPEAT, 0},
	298	{"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
	299	{"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
	300	{"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
	301	{"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
	302	{"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
	303	{"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
	304	{"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
	305	{"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
	306	{"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
f486487f	307	{NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
c906108c SS	308	};
	309	\f
	310	/* The built-in types of Modula-2. */
	311
cad351d1 UW	312	enum m2_primitive_types {
	313	m2_primitive_type_char,
	314	m2_primitive_type_int,
	315	m2_primitive_type_card,
	316	m2_primitive_type_real,
	317	m2_primitive_type_bool,
	318	nr_m2_primitive_types
c906108c SS	319	};
c906108c SS	320
cad351d1 UW	321	static void
	322	m2_language_arch_info (struct gdbarch *gdbarch,
	323	struct language_arch_info *lai)
	324	{
5760b90a UW	325	const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
	326
	327	lai->string_char_type = builtin->builtin_char;
cad351d1 UW	328	lai->primitive_type_vector
	329	= GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
	330	struct type *);
	331
	332	lai->primitive_type_vector [m2_primitive_type_char]
5760b90a	333	= builtin->builtin_char;
cad351d1	334	lai->primitive_type_vector [m2_primitive_type_int]
5760b90a	335	= builtin->builtin_int;
cad351d1	336	lai->primitive_type_vector [m2_primitive_type_card]
5760b90a	337	= builtin->builtin_card;
cad351d1	338	lai->primitive_type_vector [m2_primitive_type_real]
5760b90a	339	= builtin->builtin_real;
cad351d1	340	lai->primitive_type_vector [m2_primitive_type_bool]
5760b90a	341	= builtin->builtin_bool;
fbb06eb1 UW	342
	343	lai->bool_type_symbol = "BOOLEAN";
	344	lai->bool_type_default = builtin->builtin_bool;
cad351d1 UW	345	}
cad351d1 UW	346
844781a1 GM	347	const struct exp_descriptor exp_descriptor_modula2 =
	348	{
	349	print_subexp_standard,
	350	operator_length_standard,
c0201579	351	operator_check_standard,
844781a1 GM	352	op_name_standard,
	353	dump_subexp_body_standard,
	354	evaluate_subexp_modula2
	355	};
	356
c5aa993b JM	357	const struct language_defn m2_language_defn =
c5aa993b JM	358	{
c906108c	359	"modula-2",
6abde28f	360	"Modula-2",
c906108c	361	language_m2,
c906108c	362	range_check_on,
63872f9d	363	case_sensitive_on,
7ca2d3a3	364	array_row_major,
9a044a89	365	macro_expansion_no,
56618e20	366	NULL,
844781a1	367	&exp_descriptor_modula2,
c906108c	368	m2_parse, /* parser */
b3f11165	369	m2_yyerror, /* parser error function */
e85c3284	370	null_post_parser,
c906108c SS	371	m2_printchar, /* Print character constant */
	372	m2_printstr, /* function to print string constant */
	373	m2_emit_char, /* Function to print a single character */
c906108c	374	m2_print_type, /* Print a type using appropriate syntax */
5c6ce71d	375	m2_print_typedef, /* Print a typedef using appropriate syntax */
c906108c SS	376	m2_val_print, /* Print a value using appropriate syntax */
c906108c SS	377	c_value_print, /* Print a top-level value */
a5ee536b	378	default_read_var_value, /* la_read_var_value */
f636b87d	379	NULL, /* Language specific skip_trampoline */
2b2d9e11	380	NULL, /* name_of_this */
5f9a71c3	381	basic_lookup_symbol_nonlocal, /* lookup_symbol_nonlocal */
b368761e	382	basic_lookup_transparent_type,/* lookup_transparent_type */
9a3d7dfd	383	NULL, /* Language specific symbol demangler */
8b302db8	384	NULL,
025bb325 MS	385	NULL, /* Language specific
025bb325 MS	386	class_name_from_physname */
c906108c SS	387	m2_op_print_tab, /* expression operators for printing */
	388	0, /* arrays are first-class (not c-style) */
	389	0, /* String lower bound */
6084f43a	390	default_word_break_characters,
41d27058	391	default_make_symbol_completion_list,
cad351d1	392	m2_language_arch_info,
e79af960	393	default_print_array_index,
41f1b697	394	default_pass_by_reference,
ae6a3a4c	395	default_get_string,
1a119f36	396	NULL, /* la_get_symbol_name_cmp */
f8eba3c6	397	iterate_over_symbols,
a53b64ea	398	&default_varobj_ops,
bb2ec1b3 TT	399	NULL,
bb2ec1b3 TT	400	NULL,
c906108c SS	401	LANG_MAGIC
	402	};
	403
5760b90a UW	404	static void *
5760b90a UW	405	build_m2_types (struct gdbarch *gdbarch)
c906108c	406	{
5760b90a UW	407	struct builtin_m2_type *builtin_m2_type
	408	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
	409
c906108c	410	/* Modula-2 "pervasive" types. NOTE: these can be redefined!!! */
e9bb382b UW	411	builtin_m2_type->builtin_int
	412	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
	413	builtin_m2_type->builtin_card
	414	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
	415	builtin_m2_type->builtin_real
49f190bc UW	416	= arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
49f190bc UW	417	gdbarch_float_format (gdbarch));
e9bb382b UW	418	builtin_m2_type->builtin_char
	419	= arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
	420	builtin_m2_type->builtin_bool
	421	= arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
c906108c	422
5760b90a UW	423	return builtin_m2_type;
	424	}
	425
	426	static struct gdbarch_data *m2_type_data;
	427
	428	const struct builtin_m2_type *
	429	builtin_m2_type (struct gdbarch *gdbarch)
	430	{
9a3c8263	431	return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
5760b90a UW	432	}
	433
	434
	435	/* Initialization for Modula-2 */
	436
	437	void
	438	_initialize_m2_language (void)
	439	{
	440	m2_type_data = gdbarch_data_register_post_init (build_m2_types);
	441
c906108c SS	442	add_language (&m2_language_defn);
c906108c SS	443	}