[thirdparty/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 *);

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

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

/* Class representing the M2 language.  */

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

  /* See language.h.  */

  const char *name () const override
  { return "modula-2"; }

  /* See language.h.  */

  const char *natural_name () const override
  { return "Modula-2"; }

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

  /* See language.h.  */

  void emitchar (int ch, struct type *chtype,
		 struct ui_file *stream, int quoter) const override
  {
    ch &= 0xFF;			/* Avoid sign bit follies.  */

    if (PRINT_LITERAL_FORM (ch))
      {
	if (ch == '\\' || ch == quoter)
	  fputs_filtered ("\\", stream);
	fprintf_filtered (stream, "%c", ch);
      }
    else
      {
	switch (ch)
	  {
	  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) ch);
	    break;
	  }
      }
  }

  /* See language.h.  */

  void printchar (int ch, struct type *chtype,
		  struct ui_file *stream) const override
  {
    m2_printchar (ch, chtype, stream);
  }

  /* See language.h.  */

  void printstr (struct ui_file *stream, struct type *elttype,
		 const gdb_byte *string, unsigned int length,
		 const char *encoding, int force_ellipses,
		 const struct value_print_options *options) const override
  {
    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], elttype, 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], elttype, stream, '"');
	    ++things_printed;
	  }
      }

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

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

  /* See language.h.  */

  void print_typedef (struct type *type, struct symbol *new_symbol,
		      struct ui_file *stream) const override
  {
    m2_print_typedef (type, new_symbol, stream);
  }

  /* See language.h.  */

  bool is_string_type_p (struct type *type) const override
  {
    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;
  }

  /* See language.h.  */

  bool c_style_arrays_p () const override
  { return false; }

  /* See language.h.  Despite not having C-style arrays, Modula-2 uses 0
     for its string lower bounds.  */

  char string_lower_bound () const override
  { return 0; }

  /* See language.h.  */

  bool range_checking_on_by_default () const override
  { return true; }

  /* See language.h.  */

  const struct exp_descriptor *expression_ops () const override
  { return &exp_descriptor_modula2; }

  /* See language.h.  */

  const struct op_print *opcode_print_table () const override
  { return m2_op_print_tab; }
};

/* 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	32	static void m2_printchar (int, struct type , struct ui_file );
c906108c SS	33
c906108c SS	34	/* FIXME: This is a copy of the same function from c-exp.y. It should
844781a1	35	be replaced with a true Modula version. */
c906108c SS	36
c906108c SS	37	static void
6c7a06a3	38	m2_printchar (int c, struct type type, struct ui_file stream)
c906108c SS	39	{
c906108c SS	40	fputs_filtered ("'", stream);
6c7a06a3	41	LA_EMIT_CHAR (c, type, stream, '\'');
c906108c SS	42	fputs_filtered ("'", stream);
	43	}
	44
844781a1 GM	45	static struct value *
	46	evaluate_subexp_modula2 (struct type expect_type, struct expression exp,
	47	int *pos, enum noside noside)
	48	{
	49	enum exp_opcode op = exp->elts[*pos].opcode;
	50	struct value *arg1;
	51	struct value *arg2;
	52	struct type *type;
b8d56208	53
844781a1 GM	54	switch (op)
	55	{
	56	case UNOP_HIGH:
	57	(*pos)++;
	58	arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
	59
	60	if (noside == EVAL_SKIP \|\| noside == EVAL_AVOID_SIDE_EFFECTS)
	61	return arg1;
	62	else
	63	{
	64	arg1 = coerce_ref (arg1);
	65	type = check_typedef (value_type (arg1));
	66
	67	if (m2_is_unbounded_array (type))
	68	{
	69	struct value *temp = arg1;
b8d56208	70
940da03e	71	type = type->field (1).type ();
844781a1 GM	72	/* i18n: Do not translate the "_m2_high" part! */
	73	arg1 = value_struct_elt (&temp, NULL, "_m2_high", NULL,
	74	_("unbounded structure "
	75	"missing _m2_high field"));
	76
	77	if (value_type (arg1) != type)
	78	arg1 = value_cast (type, arg1);
	79	}
	80	}
	81	return arg1;
	82
	83	case BINOP_SUBSCRIPT:
	84	(*pos)++;
	85	arg1 = evaluate_subexp_with_coercion (exp, pos, noside);
	86	arg2 = evaluate_subexp_with_coercion (exp, pos, noside);
	87	if (noside == EVAL_SKIP)
	88	goto nosideret;
	89	/* If the user attempts to subscript something that is not an
	90	array or pointer type (like a plain int variable for example),
	91	then report this as an error. */
	92
	93	arg1 = coerce_ref (arg1);
	94	type = check_typedef (value_type (arg1));
	95
	96	if (m2_is_unbounded_array (type))
	97	{
	98	struct value *temp = arg1;
940da03e	99	type = type->field (0).type ();
78134374	100	if (type == NULL \|\| (type->code () != TYPE_CODE_PTR))
b8d56208	101	{
025bb325 MS	102	warning (_("internal error: unbounded "
025bb325 MS	103	"array structure is unknown"));
b8d56208 MS	104	return evaluate_subexp_standard (expect_type, exp, pos, noside);
b8d56208 MS	105	}
844781a1 GM	106	/* i18n: Do not translate the "_m2_contents" part! */
	107	arg1 = value_struct_elt (&temp, NULL, "_m2_contents", NULL,
	108	_("unbounded structure "
	109	"missing _m2_contents field"));
	110
	111	if (value_type (arg1) != type)
	112	arg1 = value_cast (type, arg1);
	113
976aa66e	114	check_typedef (value_type (arg1));
2497b498	115	return value_ind (value_ptradd (arg1, value_as_long (arg2)));
844781a1 GM	116	}
844781a1 GM	117	else
78134374	118	if (type->code () != TYPE_CODE_ARRAY)
844781a1	119	{
7d93a1e0	120	if (type->name ())
844781a1	121	error (_("cannot subscript something of type `%s'"),
7d93a1e0	122	type->name ());
844781a1 GM	123	else
	124	error (_("cannot subscript requested type"));
	125	}
	126
	127	if (noside == EVAL_AVOID_SIDE_EFFECTS)
	128	return value_zero (TYPE_TARGET_TYPE (type), VALUE_LVAL (arg1));
	129	else
2497b498	130	return value_subscript (arg1, value_as_long (arg2));
844781a1 GM	131
	132	default:
	133	return evaluate_subexp_standard (expect_type, exp, pos, noside);
	134	}
	135
	136	nosideret:
22601c15	137	return value_from_longest (builtin_type (exp->gdbarch)->builtin_int, 1);
844781a1	138	}
c906108c	139	\f
c5aa993b	140
c906108c SS	141	/* Table of operators and their precedences for printing expressions. */
c906108c SS	142
c5aa993b JM	143	static const struct op_print m2_op_print_tab[] =
	144	{
	145	{"+", BINOP_ADD, PREC_ADD, 0},
	146	{"+", UNOP_PLUS, PREC_PREFIX, 0},
	147	{"-", BINOP_SUB, PREC_ADD, 0},
	148	{"-", UNOP_NEG, PREC_PREFIX, 0},
	149	{"*", BINOP_MUL, PREC_MUL, 0},
	150	{"/", BINOP_DIV, PREC_MUL, 0},
	151	{"DIV", BINOP_INTDIV, PREC_MUL, 0},
	152	{"MOD", BINOP_REM, PREC_MUL, 0},
	153	{":=", BINOP_ASSIGN, PREC_ASSIGN, 1},
	154	{"OR", BINOP_LOGICAL_OR, PREC_LOGICAL_OR, 0},
	155	{"AND", BINOP_LOGICAL_AND, PREC_LOGICAL_AND, 0},
	156	{"NOT", UNOP_LOGICAL_NOT, PREC_PREFIX, 0},
	157	{"=", BINOP_EQUAL, PREC_EQUAL, 0},
	158	{"<>", BINOP_NOTEQUAL, PREC_EQUAL, 0},
	159	{"<=", BINOP_LEQ, PREC_ORDER, 0},
	160	{">=", BINOP_GEQ, PREC_ORDER, 0},
	161	{">", BINOP_GTR, PREC_ORDER, 0},
	162	{"<", BINOP_LESS, PREC_ORDER, 0},
	163	{"^", UNOP_IND, PREC_PREFIX, 0},
	164	{"@", BINOP_REPEAT, PREC_REPEAT, 0},
	165	{"CAP", UNOP_CAP, PREC_BUILTIN_FUNCTION, 0},
	166	{"CHR", UNOP_CHR, PREC_BUILTIN_FUNCTION, 0},
	167	{"ORD", UNOP_ORD, PREC_BUILTIN_FUNCTION, 0},
	168	{"FLOAT", UNOP_FLOAT, PREC_BUILTIN_FUNCTION, 0},
	169	{"HIGH", UNOP_HIGH, PREC_BUILTIN_FUNCTION, 0},
	170	{"MAX", UNOP_MAX, PREC_BUILTIN_FUNCTION, 0},
	171	{"MIN", UNOP_MIN, PREC_BUILTIN_FUNCTION, 0},
	172	{"ODD", UNOP_ODD, PREC_BUILTIN_FUNCTION, 0},
	173	{"TRUNC", UNOP_TRUNC, PREC_BUILTIN_FUNCTION, 0},
f486487f	174	{NULL, OP_NULL, PREC_BUILTIN_FUNCTION, 0}
c906108c SS	175	};
	176	\f
	177	/* The built-in types of Modula-2. */
	178
cad351d1 UW	179	enum m2_primitive_types {
	180	m2_primitive_type_char,
	181	m2_primitive_type_int,
	182	m2_primitive_type_card,
	183	m2_primitive_type_real,
	184	m2_primitive_type_bool,
	185	nr_m2_primitive_types
c906108c SS	186	};
c906108c SS	187
844781a1 GM	188	const struct exp_descriptor exp_descriptor_modula2 =
	189	{
	190	print_subexp_standard,
	191	operator_length_standard,
c0201579	192	operator_check_standard,
844781a1 GM	193	op_name_standard,
	194	dump_subexp_body_standard,
	195	evaluate_subexp_modula2
	196	};
	197
0874fd07 AB	198	/* Class representing the M2 language. */
	199
	200	class m2_language : public language_defn
	201	{
	202	public:
	203	m2_language ()
0e25e767	204	: language_defn (language_m2)
0874fd07	205	{ /* Nothing. */ }
1fb314aa	206
6f7664a9 AB	207	/* See language.h. */
	208
	209	const char *name () const override
	210	{ return "modula-2"; }
	211
	212	/* See language.h. */
	213
	214	const char *natural_name () const override
	215	{ return "Modula-2"; }
	216
1fb314aa AB	217	/* See language.h. */
	218	void language_arch_info (struct gdbarch *gdbarch,
	219	struct language_arch_info *lai) const override
	220	{
	221	const struct builtin_m2_type *builtin = builtin_m2_type (gdbarch);
	222
	223	lai->string_char_type = builtin->builtin_char;
	224	lai->primitive_type_vector
	225	= GDBARCH_OBSTACK_CALLOC (gdbarch, nr_m2_primitive_types + 1,
	226	struct type *);
	227
	228	lai->primitive_type_vector [m2_primitive_type_char]
	229	= builtin->builtin_char;
	230	lai->primitive_type_vector [m2_primitive_type_int]
	231	= builtin->builtin_int;
	232	lai->primitive_type_vector [m2_primitive_type_card]
	233	= builtin->builtin_card;
	234	lai->primitive_type_vector [m2_primitive_type_real]
	235	= builtin->builtin_real;
	236	lai->primitive_type_vector [m2_primitive_type_bool]
	237	= builtin->builtin_bool;
	238
	239	lai->bool_type_symbol = "BOOLEAN";
	240	lai->bool_type_default = builtin->builtin_bool;
	241	}
fbfb0a46 AB	242
	243	/* See language.h. */
	244
	245	void print_type (struct type type, const char varstring,
	246	struct ui_file *stream, int show, int level,
	247	const struct type_print_options *flags) const override
	248	{
	249	m2_print_type (type, varstring, stream, show, level, flags);
	250	}
ebe2334e AB	251
	252	/* See language.h. */
	253
	254	void value_print_inner
	255	(struct value val, struct ui_file stream, int recurse,
	256	const struct value_print_options *options) const override
	257	{
	258	return m2_value_print_inner (val, stream, recurse, options);
	259	}
87afa652 AB	260
	261	/* See language.h. */
	262
	263	int parser (struct parser_state *ps) const override
	264	{
	265	return m2_parse (ps);
	266	}
ec8cec5b AB	267
	268	/* See language.h. */
	269
	270	void emitchar (int ch, struct type *chtype,
	271	struct ui_file *stream, int quoter) const override
	272	{
	273	ch &= 0xFF; /* Avoid sign bit follies. */
	274
	275	if (PRINT_LITERAL_FORM (ch))
	276	{
	277	if (ch == '\\' \|\| ch == quoter)
	278	fputs_filtered ("\\", stream);
	279	fprintf_filtered (stream, "%c", ch);
	280	}
	281	else
	282	{
	283	switch (ch)
	284	{
	285	case '\n':
	286	fputs_filtered ("\\n", stream);
	287	break;
	288	case '\b':
	289	fputs_filtered ("\\b", stream);
	290	break;
	291	case '\t':
	292	fputs_filtered ("\\t", stream);
	293	break;
	294	case '\f':
	295	fputs_filtered ("\\f", stream);
	296	break;
	297	case '\r':
	298	fputs_filtered ("\\r", stream);
	299	break;
	300	case '\033':
	301	fputs_filtered ("\\e", stream);
	302	break;
	303	case '\007':
	304	fputs_filtered ("\\a", stream);
	305	break;
	306	default:
	307	fprintf_filtered (stream, "\\%.3o", (unsigned int) ch);
	308	break;
	309	}
	310	}
	311	}
52b50f2c AB	312
	313	/* See language.h. */
	314
	315	void printchar (int ch, struct type *chtype,
	316	struct ui_file *stream) const override
	317	{
	318	m2_printchar (ch, chtype, stream);
	319	}
d711ee67 AB	320
	321	/* See language.h. */
	322
	323	void printstr (struct ui_file stream, struct type elttype,
	324	const gdb_byte *string, unsigned int length,
	325	const char *encoding, int force_ellipses,
	326	const struct value_print_options *options) const override
	327	{
	328	unsigned int i;
	329	unsigned int things_printed = 0;
	330	int in_quotes = 0;
	331	int need_comma = 0;
	332
	333	if (length == 0)
	334	{
	335	fputs_filtered ("\"\"", gdb_stdout);
	336	return;
	337	}
	338
	339	for (i = 0; i < length && things_printed < options->print_max; ++i)
	340	{
	341	/* Position of the character we are examining
	342	to see whether it is repeated. */
	343	unsigned int rep1;
	344	/* Number of repetitions we have detected so far. */
	345	unsigned int reps;
	346
	347	QUIT;
	348
	349	if (need_comma)
	350	{
	351	fputs_filtered (", ", stream);
	352	need_comma = 0;
	353	}
	354
	355	rep1 = i + 1;
	356	reps = 1;
	357	while (rep1 < length && string[rep1] == string[i])
	358	{
	359	++rep1;
	360	++reps;
	361	}
	362
	363	if (reps > options->repeat_count_threshold)
	364	{
	365	if (in_quotes)
	366	{
	367	fputs_filtered ("\", ", stream);
	368	in_quotes = 0;
	369	}
	370	m2_printchar (string[i], elttype, stream);
	371	fprintf_filtered (stream, " <repeats %u times>", reps);
	372	i = rep1 - 1;
	373	things_printed += options->repeat_count_threshold;
	374	need_comma = 1;
	375	}
	376	else
	377	{
	378	if (!in_quotes)
	379	{
	380	fputs_filtered ("\"", stream);
	381	in_quotes = 1;
	382	}
	383	LA_EMIT_CHAR (string[i], elttype, stream, '"');
384	++things_printed;
385	}
386	}
387
388	/* Terminate the quotes if necessary. */
389	if (in_quotes)
390	fputs_filtered ("\"", stream);
391
392	if (force_ellipses \|\| i < length)
393	fputs_filtered ("...", stream);
394	}
4ffc13fb AB	395
	396	/* See language.h. */
	397
	398	void print_typedef (struct type type, struct symbol new_symbol,
	399	struct ui_file *stream) const override
	400	{
	401	m2_print_typedef (type, new_symbol, stream);
	402	}
	403
39e7ecca AB	404	/* See language.h. */
	405
	406	bool is_string_type_p (struct type *type) const override
	407	{
	408	type = check_typedef (type);
	409	if (type->code () == TYPE_CODE_ARRAY
	410	&& TYPE_LENGTH (type) > 0
	411	&& TYPE_LENGTH (TYPE_TARGET_TYPE (type)) > 0)
	412	{
	413	struct type *elttype = check_typedef (TYPE_TARGET_TYPE (type));
	414
	415	if (TYPE_LENGTH (elttype) == 1
	416	&& (elttype->code () == TYPE_CODE_INT
	417	\|\| elttype->code () == TYPE_CODE_CHAR))
	418	return true;
	419	}
	420
	421	return false;
	422	}
67bd3fd5 AB	423
	424	/* See language.h. */
	425
	426	bool c_style_arrays_p () const override
	427	{ return false; }
22c12a6c AB	428
	429	/* See language.h. Despite not having C-style arrays, Modula-2 uses 0
	430	for its string lower bounds. */
	431
	432	char string_lower_bound () const override
	433	{ return 0; }
efdf6a73 AB	434
	435	/* See language.h. */
	436
	437	bool range_checking_on_by_default () const override
	438	{ return true; }
5aba6ebe AB	439
	440	/* See language.h. */
	441
	442	const struct exp_descriptor *expression_ops () const override
	443	{ return &exp_descriptor_modula2; }
b7c6e27d AB	444
	445	/* See language.h. */
	446
	447	const struct op_print *opcode_print_table () const override
	448	{ return m2_op_print_tab; }
0874fd07 AB	449	};
	450
	451	/* Single instance of the M2 language. */
	452
	453	static m2_language m2_language_defn;
	454
5760b90a UW	455	static void *
5760b90a UW	456	build_m2_types (struct gdbarch *gdbarch)
c906108c	457	{
5760b90a UW	458	struct builtin_m2_type *builtin_m2_type
	459	= GDBARCH_OBSTACK_ZALLOC (gdbarch, struct builtin_m2_type);
	460
c906108c	461	/* Modula-2 "pervasive" types. NOTE: these can be redefined!!! */
e9bb382b UW	462	builtin_m2_type->builtin_int
	463	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 0, "INTEGER");
	464	builtin_m2_type->builtin_card
	465	= arch_integer_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "CARDINAL");
	466	builtin_m2_type->builtin_real
49f190bc UW	467	= arch_float_type (gdbarch, gdbarch_float_bit (gdbarch), "REAL",
49f190bc UW	468	gdbarch_float_format (gdbarch));
e9bb382b UW	469	builtin_m2_type->builtin_char
	470	= arch_character_type (gdbarch, TARGET_CHAR_BIT, 1, "CHAR");
	471	builtin_m2_type->builtin_bool
	472	= arch_boolean_type (gdbarch, gdbarch_int_bit (gdbarch), 1, "BOOLEAN");
c906108c	473
5760b90a UW	474	return builtin_m2_type;
	475	}
	476
	477	static struct gdbarch_data *m2_type_data;
	478
	479	const struct builtin_m2_type *
	480	builtin_m2_type (struct gdbarch *gdbarch)
	481	{
9a3c8263	482	return (const struct builtin_m2_type *) gdbarch_data (gdbarch, m2_type_data);
5760b90a UW	483	}
	484
	485
	486	/* Initialization for Modula-2 */
	487
6c265988	488	void _initialize_m2_language ();
5760b90a	489	void
6c265988	490	_initialize_m2_language ()
5760b90a UW	491	{
5760b90a UW	492	m2_type_data = gdbarch_data_register_post_init (build_m2_types);
c906108c	493	}