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

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

   Copyright (C) 1992-2020 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"
#include "gdbarch.h"

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

/* Return true if TYPE is a string.  */

static bool
m2_is_string_type_p (struct type *type)
{
  type = check_typedef (type);
  if (type->code () == TYPE_CODE_ARRAY
      && TYPE_LENGTH (type) > 0
      && TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
    {
      struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));

      if (TYPE_LENGTH (elttype) == 1
	  && (elttype->code () == TYPE_CODE_INT
	      || elttype->code () == TYPE_CODE_CHAR))
	return true;
    }

  return false;
}

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 (1).type ();
	      /* 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 (0).type ();
	  if (type == NULL || (type->code () != 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_CODE_ARRAY)
	  {
	    if (type->name ())
	      error (_("cannot subscript something of type `%s'"),
		     type->name ());
	    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
};

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

/* Constant data describing the M2 language.  */

extern const struct language_data m2_language_data =
{
  "modula-2",
  "Modula-2",
  language_m2,
  range_check_on,
  case_sensitive_on,
  array_row_major,
  macro_expansion_no,
  NULL,
  &exp_descriptor_modula2,
  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_typedef,		/* Print a typedef using appropriate syntax */
  NULL,		                /* name_of_this */
  false,			/* la_store_sym_names_in_linkage_form_p */
  m2_op_print_tab,		/* expression operators for printing */
  0,				/* arrays are first-class (not c-style) */
  0,				/* String lower bound */
  &default_varobj_ops,
  m2_is_string_type_p,
  "{...}"			/* la_struct_too_deep_ellipsis */
};

/* Class representing the M2 language.  */

class m2_language : public language_defn
{
public:
  m2_language ()
    : language_defn (language_m2, m2_language_data)
  { /* Nothing.  */ }

  /* See language.h.  */
  void language_arch_info (struct gdbarch *gdbarch,
			   struct language_arch_info *lai) const override
  {
    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;
  }

  /* See language.h.  */

  void print_type (struct type *type, const char *varstring,
		   struct ui_file *stream, int show, int level,
		   const struct type_print_options *flags) const override
  {
    m2_print_type (type, varstring, stream, show, level, flags);
  }

  /* See language.h.  */

  void value_print_inner
	(struct value *val, struct ui_file *stream, int recurse,
	 const struct value_print_options *options) const override
  {
    return m2_value_print_inner (val, stream, recurse, options);
  }

  /* See language.h.  */

  int parser (struct parser_state *ps) const override
  {
    return m2_parse (ps);
  }
};

/* Single instance of the M2 language.  */

static m2_language m2_language_defn;

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
_initialize_m2_language ()
{
  m2_type_data = gdbarch_data_register_post_init (build_m2_types);
}
Commit	Line	Data
c906108c	1	/* Modula 2 language support routines for GDB, the GNU debugger.
ce27fb25	2
b811d2c2	3	Copyright (C) 1992-2020 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"
0d12e84c	30	#include "gdbarch.h"
c906108c	31
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
4be290b2 AB	178	/* Return true if TYPE is a string. */
	179
	180	static bool
	181	m2_is_string_type_p (struct type *type)
	182	{
	183	type = check_typedef (type);
78134374	184	if (type->code () == TYPE_CODE_ARRAY
4be290b2 AB	185	&& TYPE_LENGTH (type) > 0
	186	&& TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
	187	{
	188	struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
	189
	190	if (TYPE_LENGTH (elttype) == 1
78134374 SM	191	&& (elttype->code () == TYPE_CODE_INT
78134374 SM	192	\|\| elttype->code () == TYPE_CODE_CHAR))
4be290b2 AB	193	return true;
	194	}
	195
	196	return false;
	197	}
	198
844781a1 GM	199	static struct value *
	200	evaluate_subexp_modula2 (struct type expect_type, struct expression exp,
	201	int *pos, enum noside noside)
	202	{
	203	enum exp_opcode op = exp->elts[*pos].opcode;
	204	struct value *arg1;
	205	struct value *arg2;
	206	struct type *type;
b8d56208	207
844781a1 GM	208	switch (op)
	209	{
	210	case UNOP_HIGH:
	211	(*pos)++;
	212	arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
	213
	214	if (noside == EVAL_SKIP \|\| noside == EVAL_AVOID_SIDE_EFFECTS)
	215	return arg1;
	216	else
	217	{
	218	arg1 = coerce_ref (arg1);
	219	type = check_typedef (value_type (arg1));
	220
	221	if (m2_is_unbounded_array (type))
	222	{
	223	struct value *temp = arg1;
b8d56208	224
940da03e	225	type = type->field (1).type ();
844781a1 GM	226	/* i18n: Do not translate the "_m2_high" part! */
	227	arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
	228	_("unbounded structure "
	229	"missing _m2_high field"));
	230
	231	if (value_type (arg1) != type)
	232	arg1 = value_cast (type, arg1);
	233	}
	234	}
	235	return arg1;
	236
	237	case BINOP_SUBSCRIPT:
	238	(*pos)++;
	239	arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
	240	arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
	241	if (noside == EVAL_SKIP)
	242	goto nosideret;
	243	/* If the user attempts to subscript something that is not an
	244	array or pointer type (like a plain int variable for example),
	245	then report this as an error. */
	246
	247	arg1 = coerce_ref (arg1);
	248	type = check_typedef (value_type (arg1));
	249
	250	if (m2_is_unbounded_array (type))
	251	{
	252	struct value *temp = arg1;
940da03e	253	type = type->field (0).type ();
78134374	254	if (type == NULL \|\| (type->code () != TYPE_CODE_PTR))
b8d56208	255	{
025bb325 MS	256	warning (_("internal error: unbounded "
025bb325 MS	257	"array structure is unknown"));
b8d56208 MS	258	return evaluate_subexp_standard (expect_type, exp, pos, noside);
b8d56208 MS	259	}
844781a1 GM	260	/* i18n: Do not translate the "_m2_contents" part! */
	261	arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
	262	_("unbounded structure "
	263	"missing _m2_contents field"));
	264
	265	if (value_type (arg1) != type)
	266	arg1 = value_cast (type, arg1);
	267
976aa66e	268	check_typedef (value_type (arg1));
2497b498	269	return value_ind (value_ptradd (arg1, value_as_long (arg2)));
844781a1 GM	270	}
844781a1 GM	271	else
78134374	272	if (type->code () != TYPE_CODE_ARRAY)
844781a1	273	{
7d93a1e0	274	if (type->name ())
844781a1	275	error (_("cannot subscript something of type `%s'"),
7d93a1e0	276	type->name ());
844781a1 GM	277	else
	278	error (_("cannot subscript requested type"));
	279	}
	280
	281	if (noside == EVAL_AVOID_SIDE_EFFECTS)
	282	return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
	283	else
2497b498	284	return value_subscript (arg1, value_as_long (arg2));
844781a1 GM	285
	286	default:
	287	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	288	}
	289
	290	nosideret:
22601c15	291	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
844781a1	292	}
c906108c	293	\f
c5aa993b	294
c906108c SS	295	/* Table of operators and their precedences for printing expressions. */
c906108c SS	296
c5aa993b JM	297	static const struct op_print m2_op_print_tab[] =
	298	{
	299	{"+", BINOP_ADD, PREC_ADD, 0},
	300	{"+", UNOP_PLUS, PREC_PREFIX, 0},
	301	{"-", BINOP_SUB, PREC_ADD, 0},
	302	{"-", UNOP_NEG, PREC_PREFIX, 0},
	303	{"*", BINOP_MUL, PREC_MUL, 0},
	304	{"/", BINOP_DIV, PREC_MUL, 0},
	305	{"DIV", BINOP_INTDIV, PREC_MUL, 0},
	306	{"MOD", BINOP_REM, PREC_MUL, 0},
	307	{":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
	308	{"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
	309	{"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
	310	{"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
	311	{"=", BINOP_EQUAL, PREC_EQUAL, 0},
	312	{"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
	313	{"<=", BINOP_LEQ, PREC_ORDER, 0},
	314	{">=", BINOP_GEQ, PREC_ORDER, 0},
	315	{">", BINOP_GTR, PREC_ORDER, 0},
	316	{"<", BINOP_LESS, PREC_ORDER, 0},
	317	{"^", UNOP_IND, PREC_PREFIX, 0},
	318	{"@", BINOP_REPEAT, PREC_REPEAT, 0},
	319	{"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
	320	{"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
	321	{"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
	322	{"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
	323	{"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
	324	{"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
	325	{"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
	326	{"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
	327	{"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
f486487f	328	{NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
c906108c SS	329	};
	330	\f
	331	/* The built-in types of Modula-2. */
	332
cad351d1 UW	333	enum m2_primitive_types {
	334	m2_primitive_type_char,
	335	m2_primitive_type_int,
	336	m2_primitive_type_card,
	337	m2_primitive_type_real,
	338	m2_primitive_type_bool,
	339	nr_m2_primitive_types
c906108c SS	340	};
c906108c SS	341
844781a1 GM	342	const struct exp_descriptor exp_descriptor_modula2 =
	343	{
	344	print_subexp_standard,
	345	operator_length_standard,
c0201579	346	operator_check_standard,
844781a1 GM	347	op_name_standard,
	348	dump_subexp_body_standard,
	349	evaluate_subexp_modula2
	350	};
	351
0874fd07 AB	352	/* Constant data describing the M2 language. */
	353
	354	extern const struct language_data m2_language_data =
c5aa993b	355	{
c906108c	356	"modula-2",
6abde28f	357	"Modula-2",
c906108c	358	language_m2,
c906108c	359	range_check_on,
63872f9d	360	case_sensitive_on,
7ca2d3a3	361	array_row_major,
9a044a89	362	macro_expansion_no,
56618e20	363	NULL,
844781a1	364	&exp_descriptor_modula2,
e85c3284	365	null_post_parser,
c906108c SS	366	m2_printchar, /* Print character constant */
	367	m2_printstr, /* function to print string constant */
	368	m2_emit_char, /* Function to print a single character */
5c6ce71d	369	m2_print_typedef, /* Print a typedef using appropriate syntax */
2b2d9e11	370	NULL, /* name_of_this */
59cc4834	371	false, /* la_store_sym_names_in_linkage_form_p */
c906108c SS	372	m2_op_print_tab, /* expression operators for printing */
	373	0, /* arrays are first-class (not c-style) */
	374	0, /* String lower bound */
a53b64ea	375	&default_varobj_ops,
4be290b2	376	m2_is_string_type_p,
721b08c6	377	"{...}" /* la_struct_too_deep_ellipsis */
c906108c SS	378	};
c906108c SS	379
0874fd07 AB	380	/* Class representing the M2 language. */
	381
	382	class m2_language : public language_defn
	383	{
	384	public:
	385	m2_language ()
	386	: language_defn (language_m2, m2_language_data)
	387	{ /* Nothing. */ }
1fb314aa AB	388
	389	/* See language.h. */
	390	void language_arch_info (struct gdbarch *gdbarch,
	391	struct language_arch_info *lai) const override
	392	{
	393	const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
	394
	395	lai->string_char_type = builtin->builtin_char;
	396	lai->primitive_type_vector
	397	= GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
	398	struct type *);
	399
	400	lai->primitive_type_vector [m2_primitive_type_char]
	401	= builtin->builtin_char;
	402	lai->primitive_type_vector [m2_primitive_type_int]
	403	= builtin->builtin_int;
	404	lai->primitive_type_vector [m2_primitive_type_card]
	405	= builtin->builtin_card;
	406	lai->primitive_type_vector [m2_primitive_type_real]
	407	= builtin->builtin_real;
	408	lai->primitive_type_vector [m2_primitive_type_bool]
	409	= builtin->builtin_bool;
	410
	411	lai->bool_type_symbol = "BOOLEAN";
	412	lai->bool_type_default = builtin->builtin_bool;
	413	}
fbfb0a46 AB	414
	415	/* See language.h. */
	416
	417	void print_type (struct type type, const char varstring,
	418	struct ui_file *stream, int show, int level,
	419	const struct type_print_options *flags) const override
	420	{
	421	m2_print_type (type, varstring, stream, show, level, flags);
	422	}
ebe2334e AB	423
	424	/* See language.h. */
	425
	426	void value_print_inner
	427	(struct value val, struct ui_file stream, int recurse,
	428	const struct value_print_options *options) const override
	429	{
	430	return m2_value_print_inner (val, stream, recurse, options);
	431	}
87afa652 AB	432
	433	/* See language.h. */
	434
	435	int parser (struct parser_state *ps) const override
	436	{
	437	return m2_parse (ps);
	438	}
0874fd07 AB	439	};
	440
	441	/* Single instance of the M2 language. */
	442
	443	static m2_language m2_language_defn;
	444
5760b90a UW	445	static void *
5760b90a UW	446	build_m2_types (struct gdbarch *gdbarch)
c906108c	447	{
5760b90a UW	448	struct builtin_m2_type *builtin_m2_type
	449	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
	450
c906108c	451	/* Modula-2 "pervasive" types. NOTE: these can be redefined!!! */
e9bb382b UW	452	builtin_m2_type->builtin_int
	453	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
	454	builtin_m2_type->builtin_card
	455	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
	456	builtin_m2_type->builtin_real
49f190bc UW	457	= arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
49f190bc UW	458	gdbarch_float_format (gdbarch));
e9bb382b UW	459	builtin_m2_type->builtin_char
	460	= arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
	461	builtin_m2_type->builtin_bool
	462	= arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
c906108c	463
5760b90a UW	464	return builtin_m2_type;
	465	}
	466
	467	static struct gdbarch_data *m2_type_data;
	468
	469	const struct builtin_m2_type *
	470	builtin_m2_type (struct gdbarch *gdbarch)
	471	{
9a3c8263	472	return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
5760b90a UW	473	}
	474
	475
	476	/* Initialization for Modula-2 */
	477
6c265988	478	void _initialize_m2_language ();
5760b90a	479	void
6c265988	480	_initialize_m2_language ()
5760b90a UW	481	{
5760b90a UW	482	m2_type_data = gdbarch_data_register_post_init (build_m2_types);
c906108c	483	}